Playground: Improved Gist support.

You can now save and load contracts along with their simulations.
IntersectMBO · Mar 18, 2019 · 0568fdf · 0568fdf
1 parent a7ea437
commit 0568fdf
Show file tree

Hide file tree

Showing 12 changed files with 290 additions and 127 deletions.
diff --git a/meadow-client/src/Editor.purs b/meadow-client/src/Editor.purs
@@ -53,7 +53,10 @@ editorPane state =
     , br_
     , div_
         [ div [ class_ pullRight ]
-            [ gistControls (view _authStatus state) (view _createGistResult state) ]
+            [ gistControls
+                (view _authStatus state)
+                (view _createGistResult state)
+            ]
         , div_
             [ button
                 [ classes [ btn, btnClass ]
@@ -140,4 +143,4 @@ compilationErrorPane (CompilationError error) =
         [ text $ "Line " <> show error.row <> ", Column " <> show error.column <> ":" ]
     , code_
         [ pre_ [ text $ String.joinWith "\n" error.text ] ]
-    ]
+    ]
diff --git a/plutus-playground-client/src/Action.purs b/plutus-playground-client/src/Action.purs
@@ -25,7 +25,7 @@ import Network.RemoteData (RemoteData(Loading, NotAsked, Failure, Success))
 import Playground.API (EvaluationResult, _EvaluationResult, _Fn, _FunctionSchema)
 import Prelude (map, pure, show, ($), (+), (/=), (<$>), (<<<), (<>))
 import Servant.PureScript.Affjax (AjaxError)
-import Types (Action(..), ActionEvent(..), Blockchain, ChildQuery, ChildSlot, FormEvent(..), Query(..), SimpleArgument(..), Simulation, _argumentSchema, _functionName, _resultBlockchain, _simulatorWalletWallet)
+import Types (Action(..), ActionEvent(..), Blockchain, ChildQuery, ChildSlot, FormEvent(..), Query(..), SimpleArgument(..), Simulation(..), _argumentSchema, _functionName, _resultBlockchain, _simulatorWalletWallet)
 import Validation (ValidationError, WithPath, joinPath, showPathValue, validate)
 import Wallet (walletIdPane, walletsPane)
 
@@ -35,7 +35,7 @@ simulationPane ::
   => Simulation
   -> RemoteData AjaxError EvaluationResult
   -> ParentHTML Query ChildQuery ChildSlot m
-simulationPane simulation evaluationResult =
+simulationPane (Simulation simulation) evaluationResult =
   div_
     [ walletsPane simulation.signatures simulation.wallets
     , br_

diff --git a/plutus-playground-client/src/Editor.purs b/plutus-playground-client/src/Editor.purs
@@ -18,7 +18,6 @@ import Data.Lens (_Right, preview, to, view)
 import Data.Map as Map
 import Data.Maybe (Maybe(Just), fromMaybe)
 import Data.String as String
-import Gists (gistControls)
 import Halogen (HTML, action)
 import Halogen.Component (ParentHTML)
 import Halogen.HTML (ClassName(ClassName), br_, button, code_, div, div_, h3_, pre_, slot', small, strong_, text)
@@ -32,7 +31,7 @@ import Network.RemoteData (RemoteData(..), _Success, isLoading)
 import Playground.API (_CompilationResult, Warning, _Warning)
 import Prelude (Unit, bind, discard, pure, show, unit, void, ($), (<$>), (<<<), (<>))
 import StaticData as StaticData
-import Types (ChildQuery, ChildSlot, EditorSlot(..), Query(..), State, _authStatus, _compilationResult, _createGistResult, _warnings, cpEditor)
+import Types (ChildQuery, ChildSlot, EditorSlot(EditorSlot), Query(ScrollTo, LoadScript, CompileProgram, HandleEditorMessage, HandleDropEvent, HandleDragEvent), State, _compilationResult, _warnings, cpEditor)
 
 loadBuffer :: forall eff. Eff (localStorage :: LOCALSTORAGE | eff) (Maybe String)
 loadBuffer = LocalStorage.getItem StaticData.bufferLocalStorageKey
@@ -73,17 +72,13 @@ editorPane state =
         ]
     , br_
     , div_
-        [ div [ class_ pullRight ]
-            [ gistControls (view _authStatus state) (view _createGistResult state) ]
-        , div_
-            [ button
-                [ id_ "compile"
-                , classes [ btn, btnClass ]
-                , onClick $ input_ CompileProgram
-                , disabled (isLoading state.compilationResult)
-                ]
-                [ btnText ]
+        [ button
+            [ id_ "compile"
+            , classes [ btn, btnClass ]
+            , onClick $ input_ CompileProgram
+            , disabled (isLoading state.compilationResult)
             ]
+            [ btnText ]
         ]
     , br_
     , errorList

diff --git a/plutus-playground-client/src/Gists.purs b/plutus-playground-client/src/Gists.purs
@@ -1,37 +1,46 @@
 module Gists
        ( gistControls
        , mkNewGist
+       , gistSourceFilename
+       , gistSimulationFilename
+       , parseGistUrl
        )
        where
 
 import AjaxUtils (showAjaxError)
 import Auth (AuthRole(..), AuthStatus, authStatusAuthRole)
-import Bootstrap (btn, btnDanger, btnInfo, btnPrimary, nbsp)
+import Bootstrap (btn, btnBlock, btnDanger, btnInfo, btnPrimary, btnSecondary, nbsp)
+import DOM.HTML.Indexed.InputType (InputType(..))
 import Data.Argonaut.Core (stringify)
 import Data.Array (catMaybes)
 import Data.Array as Array
+import Data.Either (Either, isRight, note)
 import Data.Lens (view)
-import Data.Maybe (Maybe(..))
+import Data.Maybe (Maybe(..), fromMaybe)
 import Data.Newtype (unwrap)
-import Gist (Gist, NewGist(NewGist), NewGistFile(NewGistFile), gistHtmlUrl)
-import Halogen.HTML (ClassName(ClassName), HTML, a, br_, div, div_, text)
-import Halogen.HTML.Events (input_, onClick)
-import Halogen.HTML.Properties (class_, classes, href, id_, target)
+import Data.String.Regex (Regex, match, regex)
+import Data.String.Regex.Flags (ignoreCase)
+import Gist (Gist, GistId(..), NewGist(NewGist), NewGistFile(NewGistFile), gistHtmlUrl)
+import Halogen.HTML (ClassName(ClassName), HTML, a, br_, button, div, div_, input, text)
+import Halogen.HTML.Events (input_, onClick, onValueInput)
+import Halogen.HTML.Events as HE
+import Halogen.HTML.Properties (class_, classes, disabled, href, id_, placeholder, target, type_, value)
 import Icons (Icon(..), icon)
 import Network.RemoteData (RemoteData(NotAsked, Loading, Failure, Success))
-import Playground.API (Evaluation, SourceCode)
-import Prelude (Unit, join, ($), (<$>), (<*>), (<<<), (<>))
+import Playground.API (SourceCode)
+import Prelude (Unit, bind, not, ($), (<$>), (<<<), (<>), (=<<))
 import Servant.PureScript.Affjax (AjaxError)
 import Servant.PureScript.Settings (SPSettingsEncodeJson_(..), SPSettings_(..))
-import Types (Query(PublishGist), Simulation, toEvaluation)
+import Types (Query(..), Simulation)
 
 gistControls ::
   forall p.
   RemoteData AjaxError AuthStatus
   -> RemoteData AjaxError Gist
+  -> Maybe String
   -> HTML p (Query Unit)
-gistControls authStatus createGistResult =
-  div_
+gistControls authStatus createGistResult gistUrl =
+  div [ class_ $ ClassName "gist-controls" ]
     [ a ([ id_ "publish-gist" ] <> publishAttributes)
         publishContent
     , br_
@@ -42,33 +51,48 @@ gistControls authStatus createGistResult =
              Loading -> nbsp
              NotAsked -> nbsp
         ]
+    , button
+        [ classes ([ btn, btnBlock ] <> if canTryLoad then [ btnPrimary ] else [ btnSecondary ])
+        , onClick $ input_ $ LoadGist
+        , disabled (not canTryLoad)
+        ]
+        [ icon Github
+        , nbsp
+        , text "Load"
+        ]
+    , input [ type_ InputText
+            , value $ fromMaybe "" $ gistUrl
+            , placeholder "Paste in a Gist link"
+            , onValueInput $ HE.input SetGistUrl
+            ]
     ]
   where
+    canTryLoad = isRight $ parseGistUrl =<< note "No gist Url set" gistUrl
 
     publishAttributes =
       case (view authStatusAuthRole <$> authStatus), createGistResult of
         Failure _, _ ->
-          [ classes [ btn, btnDanger ] ]
+          [ classes [ btn, btnBlock, btnDanger ] ]
         _, Failure _ ->
-          [ classes [ btn, btnDanger ] ]
+          [ classes [ btn, btnBlock, btnDanger ] ]
         Success Anonymous, _ ->
-          [ classes [ btn, btnInfo ]
+          [ classes [ btn, btnBlock, btnInfo ]
           , href "/api/oauth/github"
           ]
         Success GithubUser, NotAsked ->
-          [ classes [ btn, btnPrimary ]
+          [ classes [ btn, btnBlock, btnPrimary ]
           , onClick $ input_ PublishGist
           ]
         Success GithubUser, Success _ ->
-          [ classes [ btn, btnPrimary ]
+          [ classes [ btn, btnBlock, btnPrimary ]
           , onClick $ input_ PublishGist
           ]
         Loading, _ ->
-          [ classes [ btn, btnInfo ] ]
+          [ classes [ btn, btnBlock, btnInfo ] ]
         _, Loading ->
-          [ classes [ btn, btnInfo ] ]
+          [ classes [ btn, btnBlock, btnInfo ] ]
         NotAsked, _ ->
-          [ classes [ btn, btnInfo ] ]
+          [ classes [ btn, btnBlock, btnInfo ] ]
 
     publishContent =
       case (view authStatusAuthRole <$> authStatus), createGistResult of
@@ -115,15 +139,28 @@ mkNewGist (SPSettings_ {encodeJson: (SPSettingsEncodeJson_ encodeJson)}) { sourc
                       , _newGistFiles: gistFiles
                       }
     where
-      evaluation :: Maybe Evaluation
-      evaluation = join $ toEvaluation <$> source <*> simulation
-
       gistFiles =
-        catMaybes [ mkNewGistFile "Playground.hs" <<< unwrap <$> source
-                  , mkNewGistFile "Simulation.json" <<< stringify <<< encodeJson <$> evaluation
+        catMaybes [ mkNewGistFile gistSourceFilename <<< unwrap <$> source
+                  , mkNewGistFile gistSimulationFilename <<< stringify <<< encodeJson <$> simulation
                   ]
 
       mkNewGistFile _newGistFilename _newGistFileContent =
         NewGistFile { _newGistFilename
                     , _newGistFileContent
                     }
+
+gistSourceFilename :: String
+gistSourceFilename = "Playground.hs"
+
+gistSimulationFilename :: String
+gistSimulationFilename = "Simulation.json"
+
+gistIdInLinkRegex :: Either String Regex
+gistIdInLinkRegex = regex "^(.*/)?([0-9a-f]{32})$" ignoreCase
+
+parseGistUrl :: String -> Either String GistId
+parseGistUrl str = do
+  gistIdInLink <- gistIdInLinkRegex
+  note "Could not parse Gist Url" $ do matches <- match gistIdInLink str
+                                       match <- Array.index matches 2
+                                       GistId <$> match
diff --git a/plutus-playground-client/src/Main.purs b/plutus-playground-client/src/Main.purs
@@ -47,8 +47,6 @@ isInstanceOf :: forall a b. Generic a => Generic b => Proxy a -> b -> Boolean
 isInstanceOf proxy value =
   isValidSpine (toSignature proxy) (toSpine value)
 
-
-
 main :: Eff (HalogenEffects (EChartsEffects (AceEffects (console :: CONSOLE, ajax :: AJAX, analytics :: ANALYTICS, localStorage :: LOCALSTORAGE, file :: FILE)))) Unit
 main = runHalogenAff do
   body <- awaitBody