553677c · obelisk · git.iko.soy

git.iko.soy/obelisk

on master help sign in

Merge remote-tracking branch 'origin/qa' into use-posix-escape

553677cOwen Shepherd7 years ago

ChangeLog.md+4−1

compare with master

unifiedsplit

@@ -11,12 +11,15 @@ This project's release branch is `master`. This log is written from the perspect

11* Add support in obelisk-route for single parameters in URL paths

12* Bump reflex-platform so that obelisk now uses reflex-dom 0.5.2.0

13* Use a `--pure` nix shell in `ob run` for parity with `ob repl` and more resilience against "works on my machine".

14−* Use `--keep NIX_PATH` for all pure shells so references to `<nixpkgs>` continues to work.

14+* Pin usages of `<nixpkgs>` in obelisk thunks, etc. to the nixpkgs used by the project's obelisk impl.

15* Backport ACMEv2 support in obelisk server to regain LetsEncrypt account creation.

16* Enable https in `ob run`

17* `ob run` now handles ghci errors better, and includes a custom ghcid

18 version. As a result, you no longer need to have ghcid installed to

19 use `ob run`, as we provide one for you.

20+* `ob` commands now complain less on systems with umasks other than `0022`.

21+* Ignore package environment files in `ob run` and `ob repl`

22+* Add `Obelisk.Route.Frontend.routeLinkDynAttr`.

21## v0.2.0.0 - 2019-8-17

24## v0.2.0.0 - 2019-8-17

FAQ.md+1−1

@@ -81,7 +81,7 @@ project's dependencies and,

81Assuming we are in a project created with `ob init`, `ob run` calls (see

82`lib/command/src/Obelisk/Command.hs`):

84− nix-shell --pure --keep NIX_PATH -A shells.ghc --run 'ob --no-handoff internal run-static-io <real-run-function>'

84+ nix-shell --pure -A shells.ghc --run 'ob --no-handoff internal run-static-io <real-run-function>'

86where

README.md+2−2

@@ -69,8 +69,8 @@ nix-env -f /path/to/obelisk -iA command

69Note that `ob` will defer to the version found in your project's `.obelisk/impl` directory. To update that version specifically:

71```shell

72−ob thunk unpack ./obelisk/impl

72+ob thunk unpack ./.obelisk/impl

73−cd ./obelisk/impl

73+cd ./.obelisk/impl

74# apply your changes

75```

default.nix+4−1

@@ -48,6 +48,7 @@ let

48 # Add obelisk packages

49 (self: super: let

50 pkgs = self.callPackage ({ pkgs }: pkgs) {};

51+ onLinux = pkg: f: if pkgs.stdenv.isLinux then f pkg else pkg;

51 in {

52 in {

52 obelisk-executable-config-inject = pkgs.obeliskExecutableConfig.platforms.web.inject self;

53 obelisk-executable-config-inject = pkgs.obeliskExecutableConfig.platforms.web.inject self;

@@ -62,7 +63,9 @@ let

62 ];

63 ];

63 };

64 };

64 obelisk-frontend = self.callCabal2nix "obelisk-frontend" (cleanSource ./lib/frontend) {};

65 obelisk-frontend = self.callCabal2nix "obelisk-frontend" (cleanSource ./lib/frontend) {};

65− obelisk-run = self.callCabal2nix "obelisk-run" (cleanSource ./lib/run) {};

66+ obelisk-run = onLinux (self.callCabal2nix "obelisk-run" (cleanSource ./lib/run) {}) (pkg:

67+ haskellLib.overrideCabal pkg (drv: { librarySystemDepends = [ pkgs.iproute ]; })

68+ );

66 obelisk-route = self.callCabal2nix "obelisk-route" (cleanSource ./lib/route) {};

69 obelisk-route = self.callCabal2nix "obelisk-route" (cleanSource ./lib/route) {};

67 obelisk-selftest = self.callCabal2nix "obelisk-selftest" (cleanSource ./lib/selftest) {};

70 obelisk-selftest = self.callCabal2nix "obelisk-selftest" (cleanSource ./lib/selftest) {};

68 obelisk-snap-extras = self.callCabal2nix "obelisk-snap-extras" (cleanSource ./lib/snap-extras) {};

71 obelisk-snap-extras = self.callCabal2nix "obelisk-snap-extras" (cleanSource ./lib/snap-extras) {};

lib/command/src/Obelisk/Command.hs+2−1

@@ -269,7 +269,8 @@ mkObeliskConfig :: IO Obelisk

269mkObeliskConfig = do

270 cliArgs <- getArgs

271 -- This function should not use argument parser (full argument parsing happens post handoff)

272+ -- TODO: See if we can use the argument parser with a subset of the parsers to get logging level out.

272− let logLevel = toLogLevel $ "-v" `elem` cliArgs

273+ let logLevel = toLogLevel $ any (`elem` ["-v", "--verbose"]) cliArgs

273 notInteractive <- not <$> isInteractiveTerm

274 notInteractive <- not <$> isInteractiveTerm

274 cliConf <- newCliConfig logLevel notInteractive notInteractive $ \case

275 cliConf <- newCliConfig logLevel notInteractive notInteractive $ \case

275 ObeliskError_ProcessError (ProcessFailure p code) ann ->

276 ObeliskError_ProcessError (ProcessFailure p code) ann ->

lib/command/src/Obelisk/Command/Deploy.hs+1−1

@@ -281,7 +281,7 @@ createKeystore root config = do

281 [ "-genkeypair", "-noprompt"

282 , "-keystore", _keytoolConfig_keystore config

283 , "-keyalg", "RSA", "-keysize", "2048"

284− , "-validity", "1000000000"

284+ , "-validity", "1000000"

285 , "-storepass", _keytoolConfig_storepass config

286 , "-alias", _keytoolConfig_alias config

287 , "-keypass", _keytoolConfig_keypass config

lib/command/src/Obelisk/Command/Project.hs+74−27

@@ -1,6 +1,7 @@

1{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE LambdaCase #-}

3{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE TemplateHaskell #-}

4module Obelisk.Command.Project

5module Obelisk.Command.Project

5 ( InitSource (..)

6 ( InitSource (..)

6 , initProject

7 , initProject

@@ -17,6 +18,7 @@ module Obelisk.Command.Project

17 , toImplDir

18 , toImplDir

18 ) where

19 ) where

21+import Control.Concurrent.MVar (MVar, newMVar, withMVarMasked)

20import Control.Monad

22import Control.Monad

21import Control.Monad.IO.Class (liftIO)

23import Control.Monad.IO.Class (liftIO)

22import Control.Monad.State

24import Control.Monad.State

@@ -25,12 +27,15 @@ import Data.Bits

25import Data.Function (on)

27import Data.Function (on)

26import qualified Data.Text as T

28import qualified Data.Text as T

27import System.Directory

29import System.Directory

30+import System.Environment (lookupEnv)

28import System.FilePath

31import System.FilePath

29import System.IO.Temp

32import System.IO.Temp

33+import System.IO.Unsafe (unsafePerformIO)

30−import System.Posix (FileStatus, UserID, deviceID, fileID, fileMode, fileOwner, getFileStatus, getRealUserID)

34+import System.Posix (FileStatus, FileMode, CMode (..), UserID, deviceID, fileID, fileMode, fileOwner, getFileStatus, getRealUserID)

31import System.Posix.Files

35import System.Posix.Files

32import System.Process (CreateProcess, cwd, proc, waitForProcess, delegate_ctlc)

36import System.Process (CreateProcess, cwd, proc, waitForProcess, delegate_ctlc)

33import Text.ShellEscape (Bash, bytes)

37import Text.ShellEscape (Bash, bytes)

38+import System.Which (staticWhich)

35import GitHub.Data.GitData (Branch)

40import GitHub.Data.GitData (Branch)

36import GitHub.Data.Name (Name)

41import GitHub.Data.Name (Name)

@@ -38,6 +43,7 @@ import GitHub.Data.Name (Name)

38import Obelisk.App (MonadObelisk)

43import Obelisk.App (MonadObelisk)

39import Obelisk.CliApp

44import Obelisk.CliApp

40import Obelisk.Command.Thunk

45import Obelisk.Command.Thunk

46+

41--TODO: Make this module resilient to random exceptions

47--TODO: Make this module resilient to random exceptions

43--TODO: Don't hardcode this

49--TODO: Don't hardcode this

@@ -54,10 +60,10 @@ obeliskSourceWithBranch branch = ThunkSource_GitHub $ GitHubSource

54 }

60 }

56data InitSource

62data InitSource

57− = InitSource_Default

63+ = InitSource_Default

58− | InitSource_Branch (Name Branch)

64+ | InitSource_Branch (Name Branch)

59− | InitSource_Symlink FilePath

65+ | InitSource_Symlink FilePath

60− deriving Show

66+ deriving Show

62-- | Path to obelisk directory in given path

68-- | Path to obelisk directory in given path

63toObeliskDir :: FilePath -> FilePath

69toObeliskDir :: FilePath -> FilePath

@@ -118,15 +124,16 @@ initProject source force = withSystemTempDirectory "ob-init" $ \tmpDir -> do

118findProjectObeliskCommand :: MonadObelisk m => FilePath -> m (Maybe FilePath)

124findProjectObeliskCommand :: MonadObelisk m => FilePath -> m (Maybe FilePath)

119findProjectObeliskCommand target = do

125findProjectObeliskCommand target = do

120 myUid <- liftIO getRealUserID

126 myUid <- liftIO getRealUserID

127+ processUmask <- liftIO getUmask

121 targetStat <- liftIO $ getFileStatus target

128 targetStat <- liftIO $ getFileStatus target

122− (result, insecurePaths) <- flip runStateT [] $ walkToProjectRoot target targetStat myUid >>= \case

129+ (result, insecurePaths) <- flip runStateT [] $ walkToProjectRoot target targetStat processUmask myUid >>= \case

123 Nothing -> pure Nothing

130 Nothing -> pure Nothing

124 Just projectRoot -> liftIO (doesDirectoryExist $ toImplDir projectRoot) >>= \case

131 Just projectRoot -> liftIO (doesDirectoryExist $ toImplDir projectRoot) >>= \case

125 False -> do

132 False -> do

126 putLog Warning $ "Found obelisk directory in " <> T.pack projectRoot <> " but the implementation (impl) file is missing"

133 putLog Warning $ "Found obelisk directory in " <> T.pack projectRoot <> " but the implementation (impl) file is missing"

127 pure Nothing

134 pure Nothing

128 True -> do

135 True -> do

129− walkToImplDir projectRoot myUid -- For security check

136+ walkToImplDir projectRoot myUid processUmask -- For security check

130 return $ Just projectRoot

137 return $ Just projectRoot

131 case (result, insecurePaths) of

138 case (result, insecurePaths) of

132 (Just projDir, []) -> do

139 (Just projDir, []) -> do

@@ -137,16 +144,36 @@ findProjectObeliskCommand target = do

137 putLog Error $ T.unlines

144 putLog Error $ T.unlines

138 [ "Error: Found a project at " <> T.pack (normalise projDir) <> ", but had to traverse one or more insecure directories to get there:"

145 [ "Error: Found a project at " <> T.pack (normalise projDir) <> ", but had to traverse one or more insecure directories to get there:"

139 , T.unlines $ fmap (T.pack . normalise) insecurePaths

146 , T.unlines $ fmap (T.pack . normalise) insecurePaths

140− , "Please ensure that all of these directories are owned by you and are not writable by anyone else."

147+ , "Please ensure that all of these directories are owned by you, not world-writable, and no more group-writable than permitted by your umask."

141 ]

148 ]

142 return Nothing

149 return Nothing

143

150

151+-- | Get the umask for the Obelisk process.

152+--

153+-- Because of

154+-- http://man7.org/linux/man-pages/man2/umask.2.html#NOTES we have to set the

155+-- umask to read it. We are using 'withMVarMasked' to guarantee that setting and

156+-- reading isn't interrupted by any exception or interleaved with another thread.

157+getUmask :: IO FileMode

158+getUmask = withMVarMasked globalUmaskLock $ \() -> do

159+ initialMask <- setFileCreationMask safeUmask

160+ void (setFileCreationMask initialMask)

161+ pure initialMask

162+ where

163+ safeUmask :: FileMode

164+ safeUmask = CMode 0o22

165+

166+{-# NOINLINE globalUmaskLock #-}

167+globalUmaskLock :: MVar ()

168+globalUmaskLock = unsafePerformIO (newMVar ())

169+

144-- | Get the FilePath to the containing project directory, if there is one

170-- | Get the FilePath to the containing project directory, if there is one

145findProjectRoot :: MonadObelisk m => FilePath -> m (Maybe FilePath)

171findProjectRoot :: MonadObelisk m => FilePath -> m (Maybe FilePath)

146findProjectRoot target = do

172findProjectRoot target = do

147 myUid <- liftIO getRealUserID

173 myUid <- liftIO getRealUserID

148 targetStat <- liftIO $ getFileStatus target

174 targetStat <- liftIO $ getFileStatus target

175+ umask <- liftIO $ getUmask

149− (result, _) <- liftIO $ runStateT (walkToProjectRoot target targetStat myUid) []

176+ (result, _) <- liftIO $ runStateT (walkToProjectRoot target targetStat umask myUid) []

150 return result

177 return result

151

178

152withProjectRoot :: MonadObelisk m => FilePath -> (FilePath -> m a) -> m a

179withProjectRoot :: MonadObelisk m => FilePath -> (FilePath -> m a) -> m a

@@ -159,15 +186,15 @@ withProjectRoot target f = findProjectRoot target >>= \case

159-- traversed in the process. Return the project root directory, if found.

186-- traversed in the process. Return the project root directory, if found.

160walkToProjectRoot

187walkToProjectRoot

161 :: (MonadState [FilePath] m, MonadIO m)

188 :: (MonadState [FilePath] m, MonadIO m)

162− => FilePath -> FileStatus -> UserID -> m (Maybe FilePath)

189+ => FilePath -> FileStatus -> FileMode -> UserID -> m (Maybe FilePath)

163−walkToProjectRoot this thisStat myUid = liftIO (doesDirectoryExist this) >>= \case

190+walkToProjectRoot this thisStat desiredUmask myUid = liftIO (doesDirectoryExist this) >>= \case

164 -- It's not a directory, so it can't be a project

191 -- It's not a directory, so it can't be a project

165 False -> do

192 False -> do

166 let dir = takeDirectory this

193 let dir = takeDirectory this

167 dirStat <- liftIO $ getFileStatus dir

194 dirStat <- liftIO $ getFileStatus dir

168− walkToProjectRoot dir dirStat myUid

195+ walkToProjectRoot dir dirStat desiredUmask myUid

169 True -> do

196 True -> do

170− when (not $ isWritableOnlyBy thisStat myUid) $ modify (this:)

197+ when (not $ isWellOwnedAndWellPermissioned thisStat myUid desiredUmask) $ modify (this:)

171 liftIO (doesDirectoryExist $ toObeliskDir this) >>= \case

198 liftIO (doesDirectoryExist $ toObeliskDir this) >>= \case

172 True -> return $ Just this

199 True -> return $ Just this

173 False -> do

200 False -> do

@@ -177,25 +204,38 @@ walkToProjectRoot this thisStat myUid = liftIO (doesDirectoryExist this) >>= \ca

177 isSameFileAs = (==) `on` fileIdentity

204 isSameFileAs = (==) `on` fileIdentity

178 if thisStat `isSameFileAs` nextStat

205 if thisStat `isSameFileAs` nextStat

179 then return Nothing -- Found a cycle; probably hit root directory

206 then return Nothing -- Found a cycle; probably hit root directory

180− else walkToProjectRoot next nextStat myUid

207+ else walkToProjectRoot next nextStat desiredUmask myUid

181

208

182-- | Walk from the given project root directory to its Obelisk implementation

209-- | Walk from the given project root directory to its Obelisk implementation

183-- directory, accumulating potentially insecure directories that were traversed

210-- directory, accumulating potentially insecure directories that were traversed

184-- in the process.

211-- in the process.

185−walkToImplDir :: (MonadState [FilePath] m, MonadIO m) => FilePath -> UserID -> m ()

212+walkToImplDir :: (MonadState [FilePath] m, MonadIO m) => FilePath -> UserID -> FileMode -> m ()

186−walkToImplDir projectRoot myUid = do

213+walkToImplDir projectRoot myUid umask = do

187 let obDir = toObeliskDir projectRoot

214 let obDir = toObeliskDir projectRoot

188 obDirStat <- liftIO $ getFileStatus obDir

215 obDirStat <- liftIO $ getFileStatus obDir

189− when (not $ isWritableOnlyBy obDirStat myUid) $ modify (obDir:)

216+ when (not $ isWellOwnedAndWellPermissioned obDirStat myUid umask) $ modify (obDir:)

190 let implThunk = obDir </> "impl"

217 let implThunk = obDir </> "impl"

191 implThunkStat <- liftIO $ getFileStatus implThunk

218 implThunkStat <- liftIO $ getFileStatus implThunk

192− when (not $ isWritableOnlyBy implThunkStat myUid) $ modify (implThunk:)

219+ when (not $ isWellOwnedAndWellPermissioned implThunkStat myUid umask) $ modify (implThunk:)

193

220

194−--TODO: Is there a better way to ask if anyone else can write things?

195−--E.g. what about ACLs?

196−-- | Check to see if directory is only writable by a user whose User ID matches the second argument provided

221+-- | Check to see if directory is writable by a user whose User ID matches the

222+-- second argument provided, and if the fact that other people can write to that

223+-- directory is in accordance with the umask of the system, passed as the third

224+-- argument.

197−isWritableOnlyBy :: FileStatus -> UserID -> Bool

225+isWellOwnedAndWellPermissioned :: FileStatus -> UserID -> FileMode -> Bool

226+isWellOwnedAndWellPermissioned s uid umask = isOwnedBy s uid && filePermissionIsSafe s umask

227+

228+isOwnedBy :: FileStatus -> UserID -> Bool

198−isWritableOnlyBy s uid = fileOwner s == uid && fileMode s .&. 0o22 == 0

229+isOwnedBy s uid = fileOwner s == uid

230+

231+-- | Check to see if a directory respect the umask, but check explicitly that

232+-- it's not world writable in any case.

233+filePermissionIsSafe :: FileStatus -> FileMode -> Bool

234+filePermissionIsSafe s umask = not fileWorldWritable && fileGroupWritable <= umaskGroupWritable

235+ where

236+ fileWorldWritable = fileMode s .&. 0o002 == 0o002

237+ fileGroupWritable = fileMode s .&. 0o020 == 0o020

238+ umaskGroupWritable = umask .&. 0o020 == 0

199

239

200inProjectProc :: MonadObelisk m => String -> [Bash] -> m ()

240inProjectProc :: MonadObelisk m => String -> [Bash] -> m ()

201inProjectProc shellName command = withProjectRoot "." $ \root ->

241inProjectProc shellName command = withProjectRoot "." $ \root ->

@@ -218,16 +258,23 @@ projectProc root isPure shellName command =

218

258

219projectShell :: MonadObelisk m => FilePath -> Bool -> String -> Maybe String -> m ()

259projectShell :: MonadObelisk m => FilePath -> Bool -> String -> Maybe String -> m ()

220projectShell root isPure shellName command = do

260projectShell root isPure shellName command = do

261+ let nixPath = $(staticWhich "nix")

262+ nixpkgsPath <- fmap T.strip $ readProcessAndLogStderr Debug $ proc nixPath ["eval", "(import .obelisk/impl {}).nixpkgs.path"]

263+ nixRemote <- liftIO $ lookupEnv "NIX_REMOTE"

221 (_, _, _, ph) <- createProcess_ "runNixShellAttr" $ setCtlc $ setCwd (Just root) $ proc "nix-shell" $

264 (_, _, _, ph) <- createProcess_ "runNixShellAttr" $ setCtlc $ setCwd (Just root) $ proc "nix-shell" $

222 [ "default.nix"] <>

265 [ "default.nix"] <>

223− -- Keep $NIX_PATH in the env for --pure shells so '<nixpkgs>' works in sub-commands

266+ ["--pure" | isPure] <>

224− -- TODO: Don't use <nixpkgs> for anything!

225− (if isPure then [ "--pure", "--keep", "NIX_PATH" ] else []) <>

226 [ "-A"

267 [ "-A"

227 , "shells." <> shellName

268 , "shells." <> shellName

228 ] <> case command of

269 ] <> case command of

229 Nothing -> []

270 Nothing -> []

230− Just c -> ["--run", c]

271+ Just c ->

272+ -- TODO: Escape nixpkgsPath and nixRemote

273+ [ "--run"

274+ , "export NIX_PATH=nixpkgs=" <> T.unpack nixpkgsPath <> "; " <>

275+ maybe "" (\v -> "export NIX_REMOTE=" <> v <> "; ") nixRemote <>

276+ c

277+ ]

231 void $ liftIO $ waitForProcess ph

278 void $ liftIO $ waitForProcess ph

232

279

233setCtlc :: CreateProcess -> CreateProcess

280setCtlc :: CreateProcess -> CreateProcess

lib/command/src/Obelisk/Command/Run.hs+9−2

@@ -221,7 +221,7 @@ runGhciRepl

221 :: MonadObelisk m

222 => FilePath -- ^ Path to .ghci

223 -> m ()

224−runGhciRepl dotGhci = inProjectProc "ghc" $ fmap (bash . BSU.fromString) $ "ghci" : ["-no-user-package-db", "-ghci-script", dotGhci]

224+runGhciRepl dotGhci = inProjectProc "ghc" $ fmap (bash . BSU.fromString) $ "ghci" : makeBaseGhciOptions dotGhci

225

226-- | Run ghcid

227runGhcid

@@ -234,12 +234,19 @@ runGhcid dotGhci mcmd = callCommand $ unwords $ $(staticWhich "ghcid") : opts

234 opts =

235 [ "-W"

236 --TODO: The decision of whether to use -fwarn-redundant-constraints should probably be made by the user

237− , "--command='ghci -Wall -ignore-dot-ghci -fwarn-redundant-constraints -no-user-package-db -ghci-script " <> dotGhci <> "' "

237+ , "--command='ghci -Wall -ignore-dot-ghci -fwarn-redundant-constraints " <> unwords (makeBaseGhciOptions dotGhci) <> "' "

238 , "--reload=config"

239 , "--outputfile=ghcid-output.txt"

240 ] <> testCmd

241 testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'")

242

243+makeBaseGhciOptions :: FilePath -> [String]

244+makeBaseGhciOptions dotGhci =

245+ [ "-no-user-package-db"

246+ , "-package-env -"

247+ , "-ghci-script " <> dotGhci

248+ ]

249+

243getFreePort :: MonadIO m => m PortNumber

250getFreePort :: MonadIO m => m PortNumber

244getFreePort = liftIO $ withSocketsDo $ do

251getFreePort = liftIO $ withSocketsDo $ do

245 addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")

252 addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")

lib/route/src/Obelisk/Route/Frontend.hs+22−6

@@ -53,6 +53,7 @@ module Obelisk.Route.Frontend

53 , runRouteToUrlT

54 , mapRouteToUrlT

55 , routeLink

56+ , routeLinkDynAttr

56 , dynRouteLink

57 , dynRouteLink

57 , adaptedUriPath

58 , adaptedUriPath

58 , setAdaptedUriPath

59 , setAdaptedUriPath

@@ -74,6 +75,7 @@ import Control.Monad.Trans.Control

74import Data.Coerce

75import Data.Coerce

75import Data.Dependent.Sum (DSum (..))

76import Data.Dependent.Sum (DSum (..))

76import Data.GADT.Compare

77import Data.GADT.Compare

78+import Data.Map (Map)

77import Data.Monoid

79import Data.Monoid

78import Data.Proxy

80import Data.Proxy

79import Data.Text (Text)

81import Data.Text (Text)

@@ -526,9 +528,7 @@ routeLink r w = do

526 setRoute $ r <$ domEvent Click e

528 setRoute $ r <$ domEvent Click e

527 return a

529 return a

528

530

529−-- | A link widget that, when clicked, sets the route to current value of the

531+-- | Like 'routeLinkDynAttr' but without custom attributes.

530−-- provided dynamic route. In non-javascript contexts the value of the dynamic post

531−-- build is used so the link still works like 'routeLink'.

532dynRouteLink

533 :: forall t m a route.

534 ( DomBuilder t m

@@ -537,11 +537,27 @@ dynRouteLink

537 , SetRoute t (R route) m

538 )

539 => Dynamic t (R route) -- ^ Target route

540− -> m a -- ^ Child widget

540+ -> m a -- ^ Child widget of the @a@ element

541+ -> m a

542+dynRouteLink = routeLinkDynAttr mempty

543+

544+-- | An @a@-tag link widget that, when clicked, sets the route to current value of the

545+-- provided dynamic route. In non-JavaScript contexts the value of the dynamic post

546+-- build is used so the link still works like 'routeLink'.

547+routeLinkDynAttr

548+ :: forall t m a route.

549+ ( DomBuilder t m

550+ , PostBuild t m

551+ , RouteToUrl (R route) m

552+ , SetRoute t (R route) m

553+ )

554+ => Dynamic t (Map AttributeName Text) -- ^ Attributes for @a@ element. Note that if @href@ is present it will be ignored

555+ -> Dynamic t (R route) -- ^ Target route

556+ -> m a -- ^ Child widget of the @a@ element

541 -> m a

557 -> m a

542−dynRouteLink dr w = do

558+routeLinkDynAttr dAttr dr w = do

543 enc <- askRouteToUrl

559 enc <- askRouteToUrl

544− er <- dynamicAttributesToModifyAttributes $ ("href" =:) . enc <$> dr

560+ er <- dynamicAttributesToModifyAttributes $ zipDynWith (<>) (("href" =:) . enc <$> dr) dAttr

545 let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))

561 let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))

546 & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> preventDefault)

562 & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> preventDefault)

547 & elementConfig_modifyAttributes .~ er

563 & elementConfig_modifyAttributes .~ er

lib/run/obelisk-run.cabal+3

@@ -48,3 +48,6 @@ library

48 exposed-modules:

49 Obelisk.Run

50 ghc-options: -Wall -fwarn-redundant-constraints

51+ if os(linux)

52+ cpp-options: -DIPROUTE_SUPPORTED

53+ build-depends: which

lib/run/src/Obelisk/Run.hs+28−15

@@ -1,3 +1,8 @@

1+{-# LANGUAGE CPP #-}

2+#if defined(IPROUTE_SUPPORTED)

3+{-# LANGUAGE TemplateHaskell #-}

4+#endif

1{-# LANGUAGE ConstraintKinds #-}

6{-# LANGUAGE ConstraintKinds #-}

2{-# LANGUAGE FlexibleContexts #-}

7{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleInstances #-}

8{-# LANGUAGE FlexibleInstances #-}

@@ -62,12 +67,15 @@ import Snap.Core (Snap)

62import System.Environment

67import System.Environment

63import System.IO

68import System.IO

64import System.Process

69import System.Process

65−import System.Exit (ExitCode(..))

66import Text.URI (URI)

70import Text.URI (URI)

67import qualified Text.URI as URI

71import qualified Text.URI as URI

68import Text.URI.Lens

72import Text.URI.Lens

69import Web.Cookie

73import Web.Cookie

75+#if defined(IPROUTE_SUPPORTED)

76+import qualified System.Which

77+#endif

78+

71run

79run

72 :: Int -- ^ Port to run the backend

80 :: Int -- ^ Port to run the backend

73 -> ([Text] -> Snap ()) -- ^ Static asset handler

81 -> ([Text] -> Snap ()) -- ^ Static asset handler

@@ -99,7 +107,7 @@ runServeAsset rootPath = Snap.serveAsset "" rootPath . T.unpack . T.intercalate

107

100getConfigRoute :: Map Text ByteString -> Either Text URI

108getConfigRoute :: Map Text ByteString -> Either Text URI

101getConfigRoute configs = case Map.lookup "common/route" configs of

109getConfigRoute configs = case Map.lookup "common/route" configs of

102− Just r ->

110+ Just r ->

103 let stripped = T.strip (T.decodeUtf8 r)

111 let stripped = T.strip (T.decodeUtf8 r)

104 in case URI.mkURI stripped of

112 in case URI.mkURI stripped of

105 Just route -> Right route

113 Just route -> Right route

@@ -122,20 +130,20 @@ runWidget conf configs frontend validFullEncoder = do

122 settings = setBeforeMainLoop beforeMainLoop (setPort port (setTimeout 3600 defaultSettings))

130 settings = setBeforeMainLoop beforeMainLoop (setPort port (setTimeout 3600 defaultSettings))

123 -- Providing TLS here will also incidentally provide it to proxied requests to the backend.

131 -- Providing TLS here will also incidentally provide it to proxied requests to the backend.

124 prepareRunner = case (uri ^? uriScheme . _Just . unRText) of

132 prepareRunner = case (uri ^? uriScheme . _Just . unRText) of

125− Just "https" -> do

133+ Just "https" -> do

126 -- Generate a private key and self-signed certificate for TLS

134 -- Generate a private key and self-signed certificate for TLS

127 privateKey <- RSA.generateRSAKey' 2048 3

135 privateKey <- RSA.generateRSAKey' 2048 3

128

136

129 certRequest <- X509Request.newX509Req

137 certRequest <- X509Request.newX509Req

130 _ <- X509Request.setPublicKey certRequest privateKey

138 _ <- X509Request.setPublicKey certRequest privateKey

131− _ <- X509Request.signX509Req certRequest privateKey Nothing

139+ _ <- X509Request.signX509Req certRequest privateKey Nothing

132

140

133 cert <- X509.newX509 >>= X509Request.makeX509FromReq certRequest

141 cert <- X509.newX509 >>= X509Request.makeX509FromReq certRequest

134 _ <- X509.setPublicKey cert privateKey

142 _ <- X509.setPublicKey cert privateKey

135 now <- getCurrentTime

143 now <- getCurrentTime

136 _ <- X509.setNotBefore cert $ addUTCTime (-1) now

144 _ <- X509.setNotBefore cert $ addUTCTime (-1) now

137 _ <- X509.setNotAfter cert $ addUTCTime (365 * 24 * 60 * 60) now

145 _ <- X509.setNotAfter cert $ addUTCTime (365 * 24 * 60 * 60) now

138− _ <- X509.signX509 cert privateKey Nothing

146+ _ <- X509.signX509 cert privateKey Nothing

139

147

140 certByteString <- BSUTF8.fromString <$> PEM.writeX509 cert

148 certByteString <- BSUTF8.fromString <$> PEM.writeX509 cert

141 privateKeyByteString <- BSUTF8.fromString <$> PEM.writePKCS8PrivateKey privateKey Nothing

149 privateKeyByteString <- BSUTF8.fromString <$> PEM.writePKCS8PrivateKey privateKey Nothing

@@ -212,17 +220,22 @@ logPortBindErr p e = getProcessIdForPort p >>= \case

212 Nothing -> putStrLn $ "runWidget: " <> show e

220 Nothing -> putStrLn $ "runWidget: " <> show e

213 Just pid -> putStrLn $ unwords [ "Port", show p, "is being used by process ID", show pid <> ".", "Please kill that process or change the port in config/common/route."]

221 Just pid -> putStrLn $ unwords [ "Port", show p, "is being used by process ID", show pid <> ".", "Please kill that process or change the port in config/common/route."]

214

222

223+ssPath :: Maybe String

224+ssPath =

225+#if defined(IPROUTE_SUPPORTED)

226+ Just $(System.Which.staticWhich "ss")

227+#else

228+ Nothing

229+#endif

230+

215getProcessIdForPort :: Int -> IO (Maybe Int)

231getProcessIdForPort :: Int -> IO (Maybe Int)

216−getProcessIdForPort port = do

232+getProcessIdForPort port = case ssPath of

217− -- First check if 'ss' is available

233+ Just ss -> do

218− (c, _, _) <- readProcessWithExitCode "which" ["ss"] mempty

219− case c of

220− ExitSuccess -> do

221− xs <- lines <$> readProcess "ss" ["-lptn", "sport = " <> show port] mempty

234+ xs <- lines <$> readProcess ss ["-lptn", "sport = " <> show port] mempty

222− case uncons xs of

235+ case uncons xs of

223− Just (_, x:_) -> return $ A.maybeResult $ A.parse parseSsPid $ BSC.pack x

236+ Just (_, x:_) -> return $ A.maybeResult $ A.parse parseSsPid $ BSC.pack x

224− _ -> return Nothing

237+ _ -> return Nothing

225− _ -> return Nothing

238+ _ -> return Nothing

226

239

227parseSsPid :: A.Parser Int

240parseSsPid :: A.Parser Int

228parseSsPid = do

241parseSsPid = do

lib/selftest/src/Obelisk/SelfTest.hs+19−17

@@ -3,7 +3,6 @@

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE PatternGuards #-}

5{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE TypeApplications #-}

7module Obelisk.SelfTest where

6module Obelisk.SelfTest where

9import Control.Exception (bracket, throw)

8import Control.Exception (bracket, throw)

@@ -71,7 +70,7 @@ shellyOb f obTest = shelly $ f obTest

71main :: IO ()

70main :: IO ()

72main = do

71main = do

73 -- Note: you can pass hspec arguments as well, eg: `-m <pattern>`

72 -- Note: you can pass hspec arguments as well, eg: `-m <pattern>`

74− isVerbose <- (elem "-v") <$> getArgs

73+ isVerbose <- elem "-v" <$> getArgs

75 unless isVerbose $

74 unless isVerbose $

76 putStrLn "Tests may take longer to run if there are unbuilt derivations: use -v for verbose output"

75 putStrLn "Tests may take longer to run if there are unbuilt derivations: use -v for verbose output"

77 let verbosity = bool silently verbosely isVerbose

76 let verbosity = bool silently verbosely isVerbose

@@ -118,7 +117,7 @@ main = do

118 it "works with master branch impl" $ inTmp $ \_ -> run "ob" ["init", "--branch", "master"]

117 it "works with master branch impl" $ inTmp $ \_ -> run "ob" ["init", "--branch", "master"]

119 it "works with symlink" $ inTmp $ \_ -> run "ob" ["init", "--symlink", obeliskImpl]

118 it "works with symlink" $ inTmp $ \_ -> run "ob" ["init", "--symlink", obeliskImpl]

120 it "doesn't silently overwrite existing files" $ withSystemTempDirectory "ob-init" $ \dir -> do

119 it "doesn't silently overwrite existing files" $ withSystemTempDirectory "ob-init" $ \dir -> do

121− let p force = (proc "ob" $ "--no-handoff" : "init" : if force then ["--force"] else []) { cwd = Just dir }

120+ let p force = (proc "ob" $ "--no-handoff" : "init" : ["--force"|force]) { cwd = Just dir }

122 (ExitSuccess, _, _) <- readCreateProcessWithExitCode (p False) ""

121 (ExitSuccess, _, _) <- readCreateProcessWithExitCode (p False) ""

123 (ExitFailure _, _, _) <- readCreateProcessWithExitCode (p False) ""

122 (ExitFailure _, _, _) <- readCreateProcessWithExitCode (p False) ""

124 (ExitSuccess, _, _) <- readCreateProcessWithExitCode (p True) ""

123 (ExitSuccess, _, _) <- readCreateProcessWithExitCode (p True) ""

@@ -128,7 +127,7 @@ main = do

128 void $ errExit False $ run "ob" ["init", "--symlink", "/dev/null"]

127 void $ errExit False $ run "ob" ["init", "--symlink", "/dev/null"]

129 ls tmp >>= liftIO . assertEqual "" []

128 ls tmp >>= liftIO . assertEqual "" []

130

129

131− it "produces a valid route config" $ inTmpObInit $ \tmp -> liftIO $ do

130+ it "produces a valid route config" $ inTmpObInit $ \tmp -> liftIO $

132 withCurrentDirectory (T.unpack $ toTextIgnore tmp) $ do

131 withCurrentDirectory (T.unpack $ toTextIgnore tmp) $ do

133 configs <- getConfigs

132 configs <- getConfigs

134 return (either (const Nothing) Just $ getConfigRoute configs) `shouldNotReturn` Nothing

133 return (either (const Nothing) Just $ getConfigRoute configs) `shouldNotReturn` Nothing

@@ -136,10 +135,8 @@ main = do

136 -- These tests fail with "Could not find module 'Obelisk.Generated.Static'"

135 -- These tests fail with "Could not find module 'Obelisk.Generated.Static'"

137 -- when not run by 'nix-build --attr selftest'

136 -- when not run by 'nix-build --attr selftest'

138 describe "ob run" $ parallel $ do

137 describe "ob run" $ parallel $ do

139− it "works in root directory" $ inTmpObInit $ \_ -> do

140− testObRunInDir p0 p1 Nothing httpManager

138+ it "works in root directory" $ inTmpObInit $ \_ -> testObRunInDir p0 p1 Nothing httpManager

141− it "works in sub directory" $ inTmpObInit $ \_ -> do

142− testObRunInDir p2 p3 (Just "frontend") httpManager

139+ it "works in sub directory" $ inTmpObInit $ \_ -> testObRunInDir p2 p3 (Just "frontend") httpManager

143

140

144 describe "obelisk project" $ parallel $ do

141 describe "obelisk project" $ parallel $ do

145 it "can build obelisk command" $ inTmpObInit $ \_ -> nixBuild ["-A", "command" , obeliskImpl]

142 it "can build obelisk command" $ inTmpObInit $ \_ -> nixBuild ["-A", "command" , obeliskImpl]

@@ -149,14 +146,19 @@ main = do

149

146

150 describe "blank initialized project" $ parallel $ do

147 describe "blank initialized project" $ parallel $ do

151

148

152− it "can build ghc.backend" $ inTmpObInit $ \_ -> do

149+ it "can build ghc.backend" $ inTmpObInit $ \_ -> nixBuild ["-A", "ghc.backend"]

153− nixBuild ["-A", "ghc.backend"]

154− it "can build ghcjs.frontend" $ inTmpObInit $ \_ -> do

150+ it "can build ghcjs.frontend" $ inTmpObInit $ \_ -> nixBuild ["-A", "ghcjs.frontend"]

155− nixBuild ["-A", "ghcjs.frontend"]

156

151

157 if os == "darwin"

152 if os == "darwin"

158− then it "can build ios" $ inTmpObInit $ \_ -> nixBuild ["-A", "ios.frontend"]

153+ then it "can build ios" $ inTmpObInit $ \_ -> nixBuild ["-A", "ios.frontend"]

154+ else it "can build android after accepting license" $ inTmpObInit $ \dir -> do

155+ let defaultNixPath = dir </> ("default.nix" :: Shelly.FilePath)

156+ writefile defaultNixPath

157+ =<< T.replace

158+ "# config.android_sdk.accept_license = false;"

159+ "config.android_sdk.accept_license = true;"

160+ <$> readfile defaultNixPath

159− else it "can build android" $ inTmpObInit $ \_ -> nixBuild ["-A", "android.frontend"]

161+ nixBuild ["-A", "android.frontend"]

160

162

161 forM_ ["ghc", "ghcjs"] $ \compiler -> do

163 forM_ ["ghc", "ghcjs"] $ \compiler -> do

162 let

164 let

@@ -191,7 +193,7 @@ main = do

191 branch' <- chdir dir $ run "git" ["rev-parse", "--abbrev-ref", "HEAD"]

193 branch' <- chdir dir $ run "git" ["rev-parse", "--abbrev-ref", "HEAD"]

192 liftIO $ assertEqual "" branch (T.strip branch')

194 liftIO $ assertEqual "" branch (T.strip branch')

193

195

194− it "can pack and unpack plain git repos" $ do

196+ it "can pack and unpack plain git repos" $

195 shelly_ $ withSystemTempDirectory "git-repo" $ \dir -> do

197 shelly_ $ withSystemTempDirectory "git-repo" $ \dir -> do

196 let repo = toTextIgnore $ dir </> ("repo" :: String)

198 let repo = toTextIgnore $ dir </> ("repo" :: String)

197 run_ "git" ["clone", "https://github.com/haskell/process.git", repo]

199 run_ "git" ["clone", "https://github.com/haskell/process.git", repo]

@@ -210,7 +212,7 @@ main = do

210 testThunkPack $ fromText repo

212 testThunkPack $ fromText repo

211

213

212 it "aborts thunk pack when there are uncommitted files" $ inTmpObInit $ \dir -> do

214 it "aborts thunk pack when there are uncommitted files" $ inTmpObInit $ \dir -> do

213− void $ unpack

215+ void unpack

214 testThunkPack (dir </> thunk)

216 testThunkPack (dir </> thunk)

215

217

216 describe "ob thunk update --branch" $ parallel $ do

218 describe "ob thunk update --branch" $ parallel $ do

@@ -289,7 +291,7 @@ alterRouteTo uri stdout = do

289

291

290-- | Handle stdout of `ob run`: check that the frontend and backend servers are started correctly

292-- | Handle stdout of `ob run`: check that the frontend and backend servers are started correctly

291handleObRunStdout :: HTTP.Manager -> Handle -> Sh Text

293handleObRunStdout :: HTTP.Manager -> Handle -> Sh Text

292−handleObRunStdout httpManager stdout = flip fix (ObRunState_Init, []) $ \loop (state, msgs) -> do

294+handleObRunStdout httpManager stdout = flip fix (ObRunState_Init, []) $ \loop (state, msgs) ->

293 liftIO (T.hGetLine stdout) >>= \t -> case state of

295 liftIO (T.hGetLine stdout) >>= \t -> case state of

294 ObRunState_Init

296 ObRunState_Init

295 | "Running test..." `T.isPrefixOf` t -> loop (ObRunState_BackendStarted, msgs)

297 | "Running test..." `T.isPrefixOf` t -> loop (ObRunState_BackendStarted, msgs)