diff --git a/README.md b/README.md index 8bcd41447c41e00fba2f042f9f9a217f227c4666..32069e17e1a1a9c48a2849b12a47973d793d9ca3 100644 --- a/README.md +++ b/README.md @@ -28,6 +28,23 @@ nix-build -A android.frontend -o result-android-frontend ./result-android-frontend/bin/deploy ``` +## Run Locally + +You can run the Obelisk application locally, without a phone. +To do so: + +```sh +nix-shell +cd obelisk +ob run +``` + +This should eventually say something like ``Frontend running on http://localhost:8008`` and you can then visit that address. +Theoretically, "a Web browser" is what's needed but Obelisk shortcomings currently demand Chrome (or Chromium). +It is advisable to make the browser window "phone-shaped" for a decent experience. +You can use "Developer Tools" to exactly size it to particular phones if you prefer. + + ## Update Dependencies ### nix-thunk @@ -38,7 +55,7 @@ These can be found in ``obelisk/dep``. Nix thunks are essentially references to git repositories. These can be unpacked to their source in-place when working on the project or packed up into a few small files. -To work with nix thunks first install the ``nix-thunk`` tool. +``nix-thunk`` is available in the nix shell provided by ``shell.nix`` at the top of the repository. Consider an example dependency "botan". From the top-level of this repo, @@ -60,3 +77,44 @@ Note: A bug in the current version of Obelisk (link?) causes trouble if certain repos are unpacked. If you have any trouble running an ``ob`` command (ob run, ob repl, etc.) with a thunk unpacked, try adding the flag ``--no-interpret obelisk/dep`` and hopefully that will sort it out. + + +## adding a new one + +Use ``nix-thunk create`` to add a new dependency. +For example, to add a thunk for *cowsay*: + +```sh +nix-thunk create https://github.com/cowsay-org/cowsay obelisk/dep/cowsay +``` + +If the dependency is a Haskell library it needs to be added to: + +* the Nix Haskell package set + (see ``obelisk/frontend/frontend.cabal``) +* the relevant section of the project's cabal file + (eg ``obelisk/frontend/frontend.cabal``) + +## updating an existing one + +Use ``nix-thunk update`` to modify an existing dependency. +For example, to switch to the release-2023 branch of *cowsay*: + +```sh +nix-thunk update --branch release-2023 obelisk/dep/cowsay +``` + +## `ob run` interactions + +``ob run`` does not pick up new dependencies. +Restart it *and* re-enter your ``nix-shell`` so it can pick up the changes. + + +## the Android build + +Test the Android build to make sure the new dependency works there too: + +```sh +cd obelisk +nix-build -A android.frontend +``` diff --git a/obelisk/common/src/Common/Route.hs b/obelisk/common/src/Common/Route.hs index 7cae8884f0675ab5e1b259aa63384b9a918c4b24..5ee3d11d3d95dee9c3d78019e3a48c13dee781a7 100644 --- a/obelisk/common/src/Common/Route.hs +++ b/obelisk/common/src/Common/Route.hs @@ -55,11 +55,6 @@ data FrontendRoute :: * -> * where -- subsequent elements identify a folder contained by that magic-folder. FrontendRoute_FileBrowser :: FrontendRoute FolderLocation - -- | Receive a folder invite code and begin to process it. The code is - -- expected to be a magic-wormhole code that can be used to get details of a - -- magic-folder invite. The route payload is the text of the invite code. - FrontendRoute_AcceptFolderInvite :: FrontendRoute Text - -- | Define the mapping between routes and URL paths & query parameters. Be -- careful to avoid defining overlapping routes because these aren't supported -- (you'll get a runtime error). @@ -74,7 +69,6 @@ fullRouteEncoder = mkFullRouteEncoder FrontendRoute_TechDemo -> PathSegment "techdemo" pathOnlyEncoder FrontendRoute_MagicFolders -> PathSegment "magic-folders" $ unitEncoder mempty FrontendRoute_FileBrowser -> PathSegment "browse" fileBrowserEncoder - FrontendRoute_AcceptFolderInvite -> PathSegment "folder-invite" $ pathOnlyEncoder . singletonListEncoder ) where fileBrowserEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Text, [Text]) PageName diff --git a/obelisk/default.nix b/obelisk/default.nix index 747b302a144f19c99547ce8a25570823dddc4101..11b02d328a243858a2605300497824c18ff087ad 100644 --- a/obelisk/default.nix +++ b/obelisk/default.nix @@ -30,6 +30,14 @@ project ./. ({ pkgs, ... }: { android.displayName = "Private Storage Mobile"; android.resources = ./frontend/android/res; android.iconPath = "@mipmap/ic_launcher"; + + # We use magic-wormhole which depends on saltine which depends on libsodium. + # We have to explicitly mention libsodium here to get it included in the + # apk. + android.runtimeSharedLibs = nixpkgs: [ + "${nixpkgs.libsodium}/lib/libsodium.so" + ]; + ios.bundleIdentifier = "systems.obsidian.obelisk.examples.minimal"; ios.bundleName = "Obelisk Minimal Example"; @@ -43,7 +51,6 @@ project ./. ({ pkgs, ... }: { inherit (ghc) haskell-language-server ghcid; nix-thunk = nix-thunk.command; }; - }) // { # Make sure we use the same nixpkgs here as we gave to obelisk / # reflex-platform above. diff --git a/obelisk/dep/haskell-magic-wormhole/default.nix b/obelisk/dep/haskell-magic-wormhole/default.nix new file mode 100644 index 0000000000000000000000000000000000000000..2b4d4ab11148e306f1f2f6acd94168ec417507e7 --- /dev/null +++ b/obelisk/dep/haskell-magic-wormhole/default.nix @@ -0,0 +1,2 @@ +# DO NOT HAND-EDIT THIS FILE +import (import ./thunk.nix) \ No newline at end of file diff --git a/obelisk/dep/haskell-magic-wormhole/github.json b/obelisk/dep/haskell-magic-wormhole/github.json new file mode 100644 index 0000000000000000000000000000000000000000..406fedfde0f828f450df16c0f0bc583af105afb8 --- /dev/null +++ b/obelisk/dep/haskell-magic-wormhole/github.json @@ -0,0 +1,8 @@ +{ + "owner": "LeastAuthority", + "repo": "haskell-magic-wormhole", + "branch": "66.app-versions.2", + "private": false, + "rev": "aff7a599101b3340a625ede22537485f2ede5804", + "sha256": "0ndsarvkqsbf0xl8ckqvgililh4x6shk8lf7fhxa9lddqq9lr9pc" +} diff --git a/obelisk/dep/haskell-magic-wormhole/thunk.nix b/obelisk/dep/haskell-magic-wormhole/thunk.nix new file mode 100644 index 0000000000000000000000000000000000000000..20f2d28c2197d35b7ec670899f978fa82e1ee23b --- /dev/null +++ b/obelisk/dep/haskell-magic-wormhole/thunk.nix @@ -0,0 +1,12 @@ +# DO NOT HAND-EDIT THIS FILE +let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: + if !fetchSubmodules && !private then builtins.fetchTarball { + url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; + } else (import (builtins.fetchTarball { + url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz"; + sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr"; +}) {}).fetchFromGitHub { + inherit owner repo rev sha256 fetchSubmodules private; + }; + json = builtins.fromJSON (builtins.readFile ./github.json); +in fetch json \ No newline at end of file diff --git a/obelisk/dep/haskell-spake2/default.nix b/obelisk/dep/haskell-spake2/default.nix new file mode 100644 index 0000000000000000000000000000000000000000..2b4d4ab11148e306f1f2f6acd94168ec417507e7 --- /dev/null +++ b/obelisk/dep/haskell-spake2/default.nix @@ -0,0 +1,2 @@ +# DO NOT HAND-EDIT THIS FILE +import (import ./thunk.nix) \ No newline at end of file diff --git a/obelisk/dep/haskell-spake2/github.json b/obelisk/dep/haskell-spake2/github.json new file mode 100644 index 0000000000000000000000000000000000000000..3cca7cb26913b920a67ebd6e9b120cc06492642b --- /dev/null +++ b/obelisk/dep/haskell-spake2/github.json @@ -0,0 +1,8 @@ +{ + "owner": "LeastAuthority", + "repo": "haskell-spake2", + "branch": "fix-build", + "private": false, + "rev": "8e2f5ba135db13163c21f3fd7d7ef95b953dac11", + "sha256": "1m0ym00x4mx28dx9ri4a13afxnw1f7d8srqzpaix6fi3s43a39sr" +} diff --git a/obelisk/dep/haskell-spake2/thunk.nix b/obelisk/dep/haskell-spake2/thunk.nix new file mode 100644 index 0000000000000000000000000000000000000000..20f2d28c2197d35b7ec670899f978fa82e1ee23b --- /dev/null +++ b/obelisk/dep/haskell-spake2/thunk.nix @@ -0,0 +1,12 @@ +# DO NOT HAND-EDIT THIS FILE +let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: + if !fetchSubmodules && !private then builtins.fetchTarball { + url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; + } else (import (builtins.fetchTarball { + url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz"; + sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr"; +}) {}).fetchFromGitHub { + inherit owner repo rev sha256 fetchSubmodules private; + }; + json = builtins.fromJSON (builtins.readFile ./github.json); +in fetch json \ No newline at end of file diff --git a/obelisk/dep/magic-foldr/git.json b/obelisk/dep/magic-foldr/git.json index c6cbccec581054b117c390920f4f1739a61a57af..82899ce3f5fe95187594713b9ec2f54f069862c9 100644 --- a/obelisk/dep/magic-foldr/git.json +++ b/obelisk/dep/magic-foldr/git.json @@ -1,8 +1,8 @@ { "url": "https://whetstone.private.storage/PrivateStorage/magic-foldr", - "rev": "70dfc907af96114c4e4a5a83e02c8abe98fce1ad", - "sha256": "0d5sxv7zx1ipgdlmyn9si4pilznjs76x2ypzpd10bvp5r9blbhkz", + "rev": "327121981eff1aabcf21b7eea5ac9ff3fede5ca5", + "sha256": "13fx8vr6cadbbic14gsmg7bmqhp3swj92wdg8kii90pfg6k4kw5q", "private": false, "fetchSubmodules": false, - "branch": "main" + "branch": "participant-directory-litcaps" } diff --git a/obelisk/frontend/frontend.cabal b/obelisk/frontend/frontend.cabal index d1059438aca7594b946e62bcdc0da48290b7db70..c0afe92f7ae8a34dd2b0d8ca9ef9928df1e8216c 100644 --- a/obelisk/frontend/frontend.cabal +++ b/obelisk/frontend/frontend.cabal @@ -13,10 +13,13 @@ extra-source-files: android-src/FrontendPaths.hs library hs-source-dirs: src - build-depends: base + build-depends: aeson + , async + , base , base32 , base64-bytestring , bytestring + , categories , cereal , common , containers @@ -27,15 +30,17 @@ library , jsaddle , jsaddle-dom , magic-foldr + , magic-wormhole , megaparsec , obelisk-executable-config-lookup , obelisk-frontend , obelisk-generated-static , obelisk-route , raw-strings-qq - , reflex-dom-core , reflex + , reflex-dom-core , req + , spake2 , tahoe-capabilities , tahoe-chk , tahoe-directory @@ -44,7 +49,6 @@ library , text , yaml - if os(android) -- Pull in the Android implementation of some platform-specific modules. hs-source-dirs: android-src @@ -85,6 +89,8 @@ library Pages.MagicFolders Pages.FirstRun Pages.TechDemo + WormholeInvite + ghc-options: -Werror -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wincomplete-record-updates -O -fno-show-valid-hole-fits executable frontend diff --git a/obelisk/frontend/src/App.hs b/obelisk/frontend/src/App.hs index e195a2126cb2c2829eca250f2637d82711cb8f09..80956f9498f393d432c6c0952db8403c7680aa42 100644 --- a/obelisk/frontend/src/App.hs +++ b/obelisk/frontend/src/App.hs @@ -12,7 +12,7 @@ import Tahoe.MagicFoldr (FolderEntry(..)) import qualified Data.Map.Strict as Map import qualified Data.Text as T import Control.Monad.Fix (MonadFix) -import Control.Monad.IO.Class (MonadIO) +import Control.Monad.IO.Class (MonadIO, liftIO) import Reflex.Class (MonadHold(holdDyn), Dynamic) import Reflex.TriggerEvent.Class (TriggerEvent) import Reflex @@ -25,6 +25,7 @@ import Reflex , current , foldDyn , fmapMaybe + , performEvent_ ) import Obelisk.Configs (HasConfigs) import Tahoe.Announcement (Announcements) @@ -40,6 +41,8 @@ data App t = App appFolderContents :: Dynamic t (Map.Map MagicFolder FolderEntry) , -- | A function which will trigger an update of the contents of one Magic-Folder. appUpdateFolder :: MagicFolder -> IO () + , -- | A function which triggers a reload of the list of all folders + appUpdateFoldersList :: Either T.Text [MagicFolder] -> IO () } @@ -58,8 +61,13 @@ initialApp startEv = do gridEv <- performEvent $ ffor startEv $ const loadGrid gridDyn <- holdDyn (Left "Loading ...") gridEv - magicFoldersEv <- performEvent $ ffor startEv $ const loadMagicFolders - magicFoldersDyn <- holdDyn (Left "Loading ...") magicFoldersEv + (updateFoldersListEv, updateFoldersList) <- newTriggerEvent + magicFoldersDyn <- foldDyn const (Left "loading ..") updateFoldersListEv + + -- update the folder list immediately at startup + performEvent_ $ ffor startEv $ \() -> liftIO $ do + f <- loadMagicFolders + updateFoldersList f -- Create a paired event/function for performing a content refresh on -- a specific magic-folder. @@ -102,7 +110,7 @@ initialApp startEv = do -- Fold the folder state up over all of the content changes. folderContentsDyn <- foldDyn updateFolderContents mempty folderContentsChanged - pure $ App gridDyn magicFoldersDyn folderContentsDyn updateFolder + pure $ App gridDyn magicFoldersDyn folderContentsDyn updateFolder updateFoldersList -- | Update the folder state associated with the given Magic-Folder. updateFolderContents :: (MagicFolder, FolderEntry) -> Map.Map MagicFolder FolderEntry -> Map.Map MagicFolder FolderEntry diff --git a/obelisk/frontend/src/Controller.hs b/obelisk/frontend/src/Controller.hs index d6f494e95036cd63e6d5fb302f37cc73626d2f4e..407b014dd58c15fb66405e2cea47c759ef7330c8 100644 --- a/obelisk/frontend/src/Controller.hs +++ b/obelisk/frontend/src/Controller.hs @@ -9,6 +9,7 @@ module Controller where import Data.Bifunctor (first) import qualified Data.Map.Strict as Map import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Fix (MonadFix) import qualified Data.Text as T import Reflex.Dom.Core import Obelisk.Route (R) @@ -43,28 +44,24 @@ pageFromRoute :: , PostBuild t m , Prerender t m , MonadHold t m + , MonadFix m + , TriggerEvent t m ) => App t -> FrontendRoute a -> RoutedT t a m () pageFromRoute _ FrontendRoute_Main = firstRunPage -pageFromRoute App{appGrid, appFolders} FrontendRoute_TechDemo = do +pageFromRoute App{appGrid, appFolders, appUpdateFoldersList} FrontendRoute_TechDemo = do r <- askRoute - techDemoPage appGrid appFolders r + techDemoPage appGrid appFolders appUpdateFoldersList r -pageFromRoute App{appFolders} FrontendRoute_MagicFolders = magicFolders appFolders +pageFromRoute App{appFolders, appUpdateFoldersList} FrontendRoute_MagicFolders = magicFolders appFolders appUpdateFoldersList pageFromRoute app@App{appFolders} FrontendRoute_FileBrowser = do r <- askRoute dyn_ $ uncurry (fileBrowserIfYouCan app) <$> r <*> appFolders -pageFromRoute _ FrontendRoute_AcceptFolderInvite = do - r <- askRoute - el "div" $ do - el "span" $ text "A folder invite code: " - el "span" $ dynText r - type FileBrowser t m = ( MonadHold t m , MonadIO (Performable m) diff --git a/obelisk/frontend/src/MagicFolder.hs b/obelisk/frontend/src/MagicFolder.hs index 89be393d23edeb817ed72f1963a1a2dd17ac36df..a4977083a8669e5b996783c138b920c983502d64 100644 --- a/obelisk/frontend/src/MagicFolder.hs +++ b/obelisk/frontend/src/MagicFolder.hs @@ -1,21 +1,22 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} module MagicFolder where +import qualified Data.ByteString as B import Data.Bifunctor (first) import Text.Megaparsec (parse) import qualified Data.Map.Strict as Map import qualified Tahoe.Directory as Directory import qualified Tahoe.SDMF as SDMF -import Text.RawString.QQ (r) import qualified Data.Text as T import Data.Yaml (decodeEither') import Tahoe.Announcement (Announcements(..)) -import Control.Monad.IO.Class (MonadIO) -import Control.Exception (SomeException) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Exception (SomeException, try) import qualified Tahoe.MagicFoldr as MF +import FrontendPaths (getFilesDir) import Obelisk.Configs (HasConfigs(getConfig)) data MagicFolder = @@ -43,34 +44,43 @@ loadGrid = do -- | Load the configured magic-folder collective capabilities. -- --- This should use getFilesDir to read a real config file. loadFolderCollectives :: MonadIO m => m (Either T.Text (Map.Map T.Text (Directory.DirectoryCapability SDMF.Reader))) loadFolderCollectives = do - case collectivesBytes of - Left err -> pure $ Left $ T.concat ["Could not read magic-folder collectives: ", T.pack $ show (err :: SomeException)] - Right bytes -> - case decodeEither' bytes of - Left err -> pure $ Left $ T.concat ["Could not parse magic-folder collectives: ", T.pack $ show err] - Right ann -> pure $ Right $ snd $ Map.mapEither (parse Directory.pReadSDMF "magic-folder collective capability") ann - where - -- TODO: Figure out how we can distribute this yaml in a separate file and - -- still be able to get at its contents, even on Android. - collectivesBytes = - Right [r| - "test dataset": "URI:DIR2-RO:wfkdyfjqfoyphuoor2z7kgoaw4:d6ggvpxkvui3glubxxaxiyp2uui4jjazwx3iupegj4whewypj2sa" - |] + appdir <- liftIO getFilesDir + case appdir of + Just fd -> do + let fname = fd <> "/magicfolders.yaml" + collectivesBytes <- liftIO $ try $ B.readFile fname + case collectivesBytes of + -- todo: too broad + Left (_ :: SomeException) -> pure $ Right mempty + Right bytes -> + case decodeEither' bytes of + Left err -> pure $ Left $ T.concat ["Could not parse magic-folder collectives: ", T.pack $ show err] + Right ann -> pure $ Right $ snd $ Map.mapEither (parse Directory.pReadSDMF "magic-folder collective capability") ann + Nothing -> pure $ Left "Can't find app config dir" -- | Load all of the locally configured/known Magic-Folders. Use the -- Magic-Foldr library representation of the folders. loadMagicFolders' :: MonadIO m => m (Either T.Text (Map.Map T.Text MF.MagicFolder)) loadMagicFolders' = ((flip MF.MagicFolder Nothing <$>) <$>) <$> loadFolderCollectives + +-- | Convert map of folders to a list of folders +convertMagicFolders :: Map.Map T.Text MF.MagicFolder -> [MagicFolder] +convertMagicFolders themap = go (Map.toList themap) where + go [] = [] + go ((n, f):fs) = MagicFolder n f : go fs + + -- | Load all of the locally configured/known Magic-Folders. Use our -- representation of the folders. loadMagicFolders :: MonadIO m => m (Either T.Text [MagicFolder]) loadMagicFolders = do folders <- loadMagicFolders' - pure . fmap (Map.elems . Map.mapWithKey MagicFolder) $ folders + pure $ case folders of + Left e -> Left e + Right f -> Right $ convertMagicFolders f -- | Read the complete directory listing of one Magic-Folder. readMagicFolder :: MonadIO m => Announcements -> MagicFolder -> m MF.FolderEntry diff --git a/obelisk/frontend/src/Pages/MagicFolders.hs b/obelisk/frontend/src/Pages/MagicFolders.hs index 4a92b1d534e9c879fc24fe39b8bc229c9b4a0fd1..b1dfa6d49f6524c72f62e9f121de553b46a9dd72 100644 --- a/obelisk/frontend/src/Pages/MagicFolders.hs +++ b/obelisk/frontend/src/Pages/MagicFolders.hs @@ -1,13 +1,20 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} -module Pages.MagicFolders (magicFolders) where +module Pages.MagicFolders (magicFolders, receiveFolderInviteText) where +import Control.Monad (void) +import qualified Data.Map.Strict as Map import qualified Data.Text as T import Reflex.Dom.Core import Obelisk.Route.Frontend import Common.Route +import Pages.TechDemo (doWormholeInvite) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Fix (MonadFix) +import Control.Concurrent (forkIO) import Static (logo) import MagicFolder @@ -18,19 +25,67 @@ data AcceptingInviteState -- ^ The UI is not currently waiting for an invite code to be entered. | EnteringCode -- ^ The UI *is* currently waiting for an invite code to be entered. + | ReceivingInvite + -- ^ We've entered a code and await the conclusion of the invite. + | InviteFinished + -- ^ The invite has concluded, for better or for worse deriving (Eq, Ord, Show) --- | A view where top-level information about all of the known magic-folders --- is shown. +-- | Show something for invite progress +indeterminateLinearProgress + :: (DomBuilder t m, PostBuild t m) => Dynamic t AcceptingInviteState -> m () +indeterminateLinearProgress acceptInviteState = do + elDynAttr "div" progressClasses $ do + elAttr "div" ("class" =: "mdc-linear-progress__buffer") $ do + elAttr "div" ("class" =: "mdc-linear-progress__buffer-bar") blank + elAttr "div" ("class" =: "mdc-linear-progress__buffer-dots") blank + elAttr "div" ("class" =: "mdc-linear-progress__bar mdc-linear-progress__primary-bar") $ do + elAttr "span" ("class" =: "mdc-linear-progress__bar-inner") blank + elAttr "div" ("class" =: "mdc-linear-progress__bar mdc-linear-progress__secondary-bar") $ do + elAttr "span" ("class" =: "mdc-linear-progress__bar-inner") blank + where + -- If you want the progress bar to always be visible, try something like this: + -- progressClasses = inviteProgressAttributes 1 <$> constDyn 1 + progressClasses = inviteProgressAttributes ReceivingInvite <$> acceptInviteState + + +-- | Compute element attributes for the top-level element of an MDC +-- indeterminate linear progress indicator, given two values which decide its +-- visibility by their equality. +inviteProgressAttributes :: Eq a => a -> a -> Map.Map T.Text T.Text +inviteProgressAttributes when now' + | when == now' = "class" =: commonClass <> commonParts + | otherwise = "class" =: (commonClass <> " mdc-linear-progress--closed") <> commonParts + where + commonClass = "mdc-linear-progress mdc-linear-progress--indeterminate" + commonParts = + "role" =: "progressbar" + <> "aria-label" =: "Invite Progress" + <> "aria-valuemin" =: "0" + <> "aria-valuemax" =: "1" + <> "aria-valuenow" =: "0" + <> "data-mdc-auto-init" =: "MDCLinearProgress" + + +inviteWidgetAttributes :: Eq a => a -> a -> Map.Map T.Text T.Text +-- XXX maybe MDC has ... a way? too +inviteWidgetAttributes when now' + | when == now' = "style" =: "visibility: visible" + | otherwise = "style" =: "visibility: hidden" + + magicFolders :: ( PerformEvent t m , DomBuilder t m , PostBuild t m , MonadHold t m + , MonadIO (Performable m) + , MonadFix m + , TriggerEvent t m , SetRoute t (R FrontendRoute) m - ) => Dynamic t (Either T.Text [MagicFolder]) -> m () -magicFolders foldersDyn = do + ) => Dynamic t (Either T.Text [MagicFolder]) -> (Either T.Text [MagicFolder] -> IO ()) -> m () +magicFolders foldersDyn updateFolders = do -- r <- askRoute -- TODO what is this for? elAttr "header" ("class" =: "mdc-top-app-bar mdc-top-app-bar--fixed" <> "data-mdc-auto-init" =: "MDCTopAppBar") $ divClass "mdc-top-app-bar__row" $ do @@ -52,17 +107,49 @@ magicFolders foldersDyn = do elClass "span" "mdc-fab__icon material-icons" $ text "add" - -- Start out in the UI state where we're not waiting for any folder - -- invite information. If someone clicks the add button, though, - -- we'll enter the state where we are waiting for the user to input - -- the invite code somehow. - acceptInviteState <- holdDyn NotAccepting (EnteringCode <$ domEvent Click add) - -- Render the current invite UI state appropriately into the page. - dyn_ $ receiveFolderInviteUI <$> acceptInviteState + -- Start out in the UI state where we're not waiting for any + -- folder invite information. We progress through the other + -- states in a circular fashion (EnteringCode, + -- ReceivingInvite, InviteFinished then back to NotAccepting) + + -- transitions: + -- click add -> EnteringCode + -- form submitted -> ReceivingInvite + -- (IO happened: folder-list updated, or...) -> InviteFinished + -- dismiss clicked -> NotAccepting + + rec + submitInviteCode <- receiveFolderInviteText acceptInviteState + + inviteCompleted <- performEventInThread $ ffor submitInviteCode $ + \code -> doWormholeInvite code >> updateFolders <$> loadMagicFolders + + let inviteEvents = [ + EnteringCode <$ domEvent Click add, + ReceivingInvite <$ submitInviteCode, + InviteFinished <$ inviteCompleted, + NotAccepting <$ never + ] + + acceptInviteState <- foldDyn const NotAccepting (leftmost inviteEvents) + + indeterminateLinearProgress acceptInviteState el "script" $ do text "mdc.autoInit();" + +-- | Execute IO actions from an event in a separate thread and produce an +-- Event that triggers with their results. Ordering is not guaranteed. +performEventInThread + :: (TriggerEvent t m, PerformEvent t m, MonadIO (Performable m)) + => Event t (IO a) + -> m (Event t a) +performEventInThread evt = + performEventAsync $ ffor evt $ + \action callback -> liftIO . void . forkIO $ action >>= callback + + -- | A widget representing a single magic-folder. folderWidget :: (DomBuilder t m, SetRoute t (R FrontendRoute) m) => MagicFolder -> m () folderWidget (MagicFolder name _state) = do @@ -76,33 +163,20 @@ folderWidget (MagicFolder name _state) = do text "Might contain magic" setRoute $ FrontendRoute_FileBrowser :/ (name, []) <$ domEvent Click theEl' --- | Choose the appropriate view related to accepting folder invite --- information given the current invite state. -receiveFolderInviteUI - :: ( PerformEvent t m - , DomBuilder t m - , SetRoute t (R FrontendRoute) m - ) => AcceptingInviteState -> m () - --- If we're not trying to accept an invite code, render nothing. -receiveFolderInviteUI NotAccepting = blank - --- If we are, render a text widget where the user can type an invite code. -receiveFolderInviteUI EnteringCode = receiveFolderInviteText - -- | A widget where a wormhole code can be submitted and when it is, the -- currently active route is changed to the invite-handling route. receiveFolderInviteText :: ( PerformEvent t m , DomBuilder t m - , SetRoute t (R FrontendRoute) m + , PostBuild t m ) - => m () -receiveFolderInviteText = do - el "div" $ do + => Dynamic t AcceptingInviteState -> m (Event t T.Text) +receiveFolderInviteText acceptInviteState = do + (_, submitInviteCode) <- elDynAttr' "div" (inviteWidgetAttributes EnteringCode <$> acceptInviteState) $ do inputEl <- inputElement $ def { _inputElementConfig_initialValue = "0-invite-code" } let submitEv = keypress Enter inputEl inputDyn = _inputElement_value inputEl - setRoute $ (FrontendRoute_AcceptFolderInvite :/) <$> tag (current inputDyn) submitEv + pure $ tag (current inputDyn) submitEv + pure submitInviteCode diff --git a/obelisk/frontend/src/Pages/TechDemo.hs b/obelisk/frontend/src/Pages/TechDemo.hs index acdf98efd5c7a6e1dce910114287fa85b513ce7e..7cacebfcccbc68d433a85dbafee36f42eb8ab329 100644 --- a/obelisk/frontend/src/Pages/TechDemo.hs +++ b/obelisk/frontend/src/Pages/TechDemo.hs @@ -10,6 +10,7 @@ module Pages.TechDemo where import Data.Either (fromRight, fromLeft) import Tahoe.Capability (confidentiallyShow) import Data.Void (Void) +import qualified Data.Map.Strict as Map import Data.Bifunctor (Bifunctor(first)) import qualified Data.ByteString.Base64 as Base64 import qualified Tahoe.Directory as Directory @@ -25,10 +26,12 @@ import JSDOM (currentWindow) import JSDOM.History (back) import JSDOM.Window (getHistory) import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString as B import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding.Error as T +import qualified Data.Yaml as Yaml import Data.ByteString.Base32 (encodeBase32Unpadded) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.List.NonEmpty (NonEmpty(..)) @@ -38,6 +41,8 @@ import Control.Monad (void) import Control.Exception (try) import Data.Serialize (encode) import Obelisk.Route.Frontend hiding (encode) + +import WormholeInvite (acceptFolderInvite, InviteMessage(..)) import qualified Tahoe.CHK.Capability as CHK import qualified Tahoe.CHK.Upload as CHK import qualified Tahoe.CHK.Types as CHK @@ -50,7 +55,7 @@ import Language.Javascript.JSaddle (eval, liftJSM) import Text.Megaparsec (ParseErrorBundle, Parsec, parse, (<|>)) import FrontendPaths (getFilesDir) import Common.Route -import MagicFolder (MagicFolder(..)) +import MagicFolder (MagicFolder(..), loadMagicFolders) techDemoPage :: ( PerformEvent t m @@ -59,9 +64,10 @@ techDemoPage ) => Dynamic t (Either T.Text Announcements) -> Dynamic t (Either T.Text [MagicFolder]) + -> (Either T.Text [MagicFolder] -> IO ()) -> Dynamic t [T.Text] -> m () -techDemoPage gridDyn foldersDyn locationDyn = prerender_ (pure ()) $ do +techDemoPage gridDyn foldersDyn updateFolders locationDyn = prerender_ (pure ()) $ do el "h1" $ text "Tech Demo" -- The API for encoding a CHK requires some servers to upload to. We @@ -129,6 +135,9 @@ techDemoPage gridDyn foldersDyn locationDyn = prerender_ (pure ()) $ do text "⇉" el "span" $ dynText $ T.pack . show <$> _rangeInput_value rg + -- Try to do some wormhole stuff + el "div" $ wormholeInviteWidget updateFolders + -- Add some buttons to get out of here. jump "main" (FrontendRoute_Main :/ ()) jump "magic-folder list" (FrontendRoute_MagicFolders :/ ()) @@ -301,6 +310,7 @@ filesDemoWidget = filesDyn <- holdDyn Nothing ev el "p" $ dynText (T.pack . show <$> filesDyn) + -- | Demonstrate doing some network I/O in a way that's integrated with -- Reflex-DOM. networkWidget :: (DomBuilder t m, Prerender t m) => m () @@ -330,6 +340,62 @@ networkWidget = pure $ Just txt +-- | Accept an invitation to a magic-folder. +doWormholeInvite + :: T.Text + -- ^ The wormhole-code for the invitation. + -> IO (Maybe T.Text) + -- ^ If the invite is is successful, Just the read cap of the collective + -- of the magic-folder. Otherwise, Nothing. +doWormholeInvite citd = do + inv <- acceptFolderInvite citd + Just fd <- getFilesDir + let fname = fd <> "/magicfolders.yaml" + raw_existing <- try $ B.readFile fname + case raw_existing of + Right raw_data -> + case Yaml.decodeEither' raw_data of + Right existing -> do + -- todo: handle conflicts + let new_folders = Map.insert (folderName inv) (collectiveReadCap inv) existing + Yaml.encodeFile fname new_folders + + Left bad -> error $ show bad + + -- duplicate-looking, but refactor this out later + Left (_ :: IOError) -> do + let new_folders = Map.insert (folderName inv) (collectiveReadCap inv) mempty + Yaml.encodeFile fname new_folders + + pure $ Just (collectiveReadCap inv) + + +-- | magic-wormhole based inviters +wormholeInviteWidget :: (DomBuilder t m, Prerender t m) => (Either T.Text [MagicFolder] -> IO ()) -> m () +wormholeInviteWidget updateFolders = + -- See filesDemoWidget for an explanation of the prerender_ call. + prerender_ blank $ do + (inviteButton, codeInputTextDyn) <- el "div" $ do + ci <- inputElement def + let citd = _inputElement_value ci + (ib, _) <- el' "button" $ text "Receive Invite" + pure (ib, citd) + let runEv = domEvent Click inviteButton + let runEvWithText = tag (current codeInputTextDyn) runEv + resultEv <- performEvent $ ffor runEvWithText $ \t -> liftIO $ do + cap <- doWormholeInvite t + mf <- loadMagicFolders + updateFolders mf + pure cap + + resultDyn <- holdDyn Nothing resultEv + el "div" $ do + el "span" $ text "Collective: " + el "span" $ dynText (fromMaybe "<unknown>" <$> resultDyn) + + + + prerenderWidget :: (Monad m, Prerender t m) => m () prerenderWidget = -- `prerender` and `prerender_` let you choose a widget to run on the server diff --git a/obelisk/frontend/src/WormholeInvite.hs b/obelisk/frontend/src/WormholeInvite.hs new file mode 100644 index 0000000000000000000000000000000000000000..a763ad7ba939531648ce9acb7fec0699c650f156 --- /dev/null +++ b/obelisk/frontend/src/WormholeInvite.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE OverloadedStrings #-} + +module WormholeInvite (InviteMessage(..), acceptFolderInvite, receiveInvite) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +-- magic-wormhole invites related imports +import MagicWormhole +import MagicWormhole.Internal.Messages (Mood(..)) +import Crypto.Spake2 (makePassword) +import Data.Text (breakOn, tail) +import GHC.Conc (atomically) +import Data.Aeson.Types (ToJSON(..), FromJSON(..), (.=), (.:), toJSON, parseJSON, object) +import qualified Data.Aeson.Types as AesonTypes +import qualified Data.Aeson as A +import Control.Exception (Exception, throwIO) +import Control.Monad.IO.Class (liftIO) + +-- | Parsing the magic-folder invitation failed. +newtype InviteParseError = InviteParseError B.ByteString deriving (Show, Eq) +instance Exception InviteParseError + +-- | Represent the version of a magic-folder invitation. +data InvitesVersion0 = InvitesVersion0 deriving (Eq, Show) + +data InviteMessage = InviteMessage { + -- This must always be "invite-v1". + kind :: T.Text, + folderName :: T.Text, + collectiveReadCap :: T.Text + } deriving (Eq, Show) + + +instance FromJSON InviteMessage where + parseJSON (AesonTypes.Object v) = + InviteMessage <$> v .: "kind" <*> v .: "folder-name" <*> v .: "collective" + parseJSON _ = error "fixme" + + +-- | Complete a Magic-Folder invitation conversation as a receiver over the +-- given wormhole connection. +performInvite :: EncryptedConnection -> IO InviteMessage +performInvite conn = do + MagicWormhole.PlainText invite_msg <- atomically $ receiveMessage conn + -- todo: should check we got a "read-only" invite + print invite_msg + sendMessage conn (MagicWormhole.PlainText "{\"protocol\": \"invite-v1\", \"kind\": \"join-folder-accept\"}") + MagicWormhole.PlainText ack_msg <- atomically $ receiveMessage conn + print ack_msg + -- pure $ fromMaybe (InviteMessage "invite-v1" "foo" "dummy") (A.decode (LBS.fromStrict invite_msg)) + -- not ^ because we want an error + case A.decode (LBS.fromStrict invite_msg) of + Nothing -> throwIO $ InviteParseError invite_msg + Just x -> pure x + + +instance ToJSON InvitesVersion0 where + toJSON InvitesVersion0 = + object ["magic-folder" .= object ["supported-messages" .= ["invite-v1" :: String]]] + +instance FromJSON InvitesVersion0 where + parseJSON (AesonTypes.Object v) = do + (AesonTypes.Object _mf) <- v .: "magic-folder" +-- supported <- mf .: "supported-messages" + return InvitesVersion0 + parseJSON _ = error "fixme" + + +-- prototyping higher-level API for haskell-magic-wormhole +-- "a" = InviteMessage for us +-- "j" is InvitesVersion0, or app-versions type +-- doWormholeInteraction :: j -> (EncryptedConnection -> IO a) -> T.Text -> IO a +-- doWormholeInteraction _appversion _interact _code = undefined + +-- "even higher", we can do a magic-folder invite +-- inviteToMagicFolder :: T.Text -> IO InviteMessage +-- inviteToMagicFolder = doWormholeInteraction InvitesVersion0 performInvite +-- equiv: inviteToMagicFolder code = doWormholeInteraction InvitesVersion0 performInvite code + +receiveInvite :: T.Text -> T.Text -> MagicWormhole.Session -> IO InviteMessage +receiveInvite nameplate code session = do + mailbox <- liftIO $ MagicWormhole.claim session (MagicWormhole.Nameplate nameplate) + peer <- liftIO $ MagicWormhole.open session mailbox + let passcode = T.encodeUtf8 . T.append (T.append nameplate "-") $ code + result <- liftIO $ MagicWormhole.withEncryptedConnection peer (Crypto.Spake2.makePassword passcode) InvitesVersion0 performInvite + MagicWormhole.release session (Just (MagicWormhole.Nameplate nameplate)) + _x <- MagicWormhole.close session (Just mailbox) (Just Happy) + pure result + +-- | Take a code like "1-foo-bar" and split off the mailbox, returning a tuple +-- like ("1", "foo-bar") +splitWormholeCode :: T.Text -> (T.Text, T.Text) +splitWormholeCode entireCode = do + let (n, c) = breakOn (T.pack "-") entireCode + let code = Data.Text.tail c + (n, code) + +-- | public API +acceptFolderInvite :: T.Text -> IO InviteMessage +acceptFolderInvite code = do + side <- MagicWormhole.generateSide + MagicWormhole.runClient endpoint appID side Nothing (receiveInvite nameplate onlycode) + where + -- codes come in like: "1-foo-bar" + (nameplate, onlycode) = splitWormholeCode code + + -- "ws://relay.magic-wormhole.io:4000/v1" + endpoint = MagicWormhole.WebSocketEndpoint "relay.magic-wormhole.io" 4000 "/v1" + + appID = MagicWormhole.AppID "private.storage/magic-folder/invites" diff --git a/obelisk/haskell-overrides.nix b/obelisk/haskell-overrides.nix index abe1be43c1f93edfc85bf6199be5a6347500e1bb..9ef790d32befae0c054b73ede59f59a2c8f87a73 100644 --- a/obelisk/haskell-overrides.nix +++ b/obelisk/haskell-overrides.nix @@ -8,6 +8,11 @@ with pkgs.haskell.lib; { (nix-thunk.thunkSource ./dep/tahoe-chk) {}; + # magic-wormhole depends on this extra crypto library. + saltine = super.saltine.overrideAttrs (old : { + nativeBuildInputs = old.nativeBuildInputs ++ [ pkgs.pkg-config ]; + }); + tahoe-ssk = self.callCabal2nix "tahoe-ssk" (nix-thunk.thunkSource ./dep/tahoe-ssk) @@ -29,6 +34,44 @@ with pkgs.haskell.lib; { (nix-thunk.thunkSource ./dep/tahoe-great-black-swamp) {}; + # this is marked as broken, because there's no python to run the + # integration tests; so we override to git our own pattern that + # skips (just) the integration test + spake2 = (self.callCabal2nix + "spake2" + (nix-thunk.thunkSource ./dep/haskell-spake2) + {}).overrideDerivation ( + oldAttrs: { + broken=false; + dontCheck=true; + checkPhase='' +set -x +runHook preCheck +./Setup test --test-options '--pattern "$2 != \"Integration\""' +runHook postCheck +''; + } + ); + + # magic-wormhole base library (similar to above, we skip the + # integration tests because no pyhthon) + + magic-wormhole = (self.callCabal2nix + "haskell-magic-wormhole" + (nix-thunk.thunkSource ./dep/haskell-magic-wormhole) + {}).overrideDerivation ( + oldAttrs: { + broken=false; + dontCheck=true; + checkPhase='' +set -x +runHook preCheck +./Setup test --test-options '--pattern "$2 != \"Integration\""' +runHook postCheck +''; + } + ); + # And the integration library that pulls the pieces together and presents a # high-level interface. gbs-downloader = self.callCabal2nix