Add halogen and first way to sync repositories from a web FE

.gitignore

@@ -11,4 +11,7 @@ config.json
 poc-config.json
 test.prs
 mvp-config.json
-.spago
+.spago
+.cache
+dist
+web-prod

package.json

@@ -18,7 +18,9 @@
     "start-dev": "spago run -w",
     "tdd": "spago test -w",
     "build": "spago build",
-    "test": "spago test"
+    "test": "spago test",
+    "serve": "parcel web/index.html --open",
+    "build-prod": "mkdir -p web-prod && cp web/index.html web-prod/ && rm -rf dist && spago bundle-app --main Web.Main --to web-prod/index.js && parcel build web-prod/index.html"
   },
   "keywords": [
     "pursescript",
@@ -37,7 +39,9 @@
   },
   "homepage": "https://github.com/hrajchert/gh-repo-sync",
   "devDependencies": {
+    "parcel": "^1.12.4",
     "purescript": "^0.13.8",
-    "purty": "^6.2.0"
+    "purty": "^6.2.0",
+    "spago": "^0.17.0"
   }
 }

spago.dhall

@@ -8,6 +8,7 @@ You can edit this file as you like.
   , "checked-exceptions"
   , "console"
   , "effect"
+  , "halogen"
   , "node-fs"
   , "prelude"
   , "psci-support"

src/Github/Entities.purs

@@ -1,9 +1,8 @@
-module Github.Entities --  (
- --  )
- where
+module Github.Entities where
 
+import Prelude
 import Simple.JSON (class ReadForeign)
-import Data.Newtype (class Newtype)
+import Data.Newtype (class Newtype, unwrap, wrap)
 import Data.Show (class Show)
 
 -- | The name of an organization
@@ -44,9 +43,20 @@ derive newtype instance readForeignBranchName :: ReadForeign BranchName
 derive newtype instance showBranchName :: Show BranchName
 
 --
--- TODO: Rename to BranchCanonical
+-- TODO: Rename to CanonicalBranch
+-- TODO: probably make newtype
 type BranchObject
   = { owner :: OrgName
     , repository :: RepoName
     , branch :: BranchName
     }
+
+branchURI :: BranchObject -> String
+branchURI { owner, repository, branch } = "@" <> unwrap owner <> "/" <> unwrap repository <> "#" <> unwrap branch
+
+canonicalBranch :: String -> String -> String -> BranchObject
+canonicalBranch owner repository branch =
+  { owner: wrap owner
+  , repository: wrap repository
+  , branch: wrap branch
+  }

src/Web/Component/RepositorySelector.purs

@@ -0,0 +1,71 @@
+module Web.Component.RepositorySelector where
+
+import Prelude (Unit, bind, pure, ($), (<<<))
+import Data.Maybe (Maybe(..))
+import Data.Newtype (unwrap, wrap)
+import Github.Entities (BranchObject, canonicalBranch)
+import Halogen as H
+import Halogen.HTML (HTML, div_, input, label_, text)
+import Halogen.HTML.Events (onValueInput)
+import Halogen.HTML.Properties as HP
+
+type State
+  = BranchObject
+
+data Action
+  = SelectOwner String
+  | SelectRepository String
+  | SelectBranch String
+
+data Query a
+  = GetBranchObject (BranchObject -> a)
+
+component :: forall i o m. H.Component HTML Query i o m
+component =
+  H.mkComponent
+    { initialState: \_ -> canonicalBranch "" "" ""
+    , render: render
+    , eval:
+        H.mkEval
+          $ H.defaultEval
+              { handleAction = handleAction
+              , handleQuery = handleQuery
+              }
+    }
+
+render :: forall cs m. State -> H.ComponentHTML Action cs m
+render state =
+  div_
+    [ label_
+        [ text "@" ]
+    , input
+        [ HP.value $ unwrap state.owner
+        , onValueInput (Just <<< SelectOwner)
+        ]
+    , label_
+        [ text "/" ]
+    , input
+        [ HP.value $ unwrap state.repository
+        , onValueInput (Just <<< SelectRepository)
+        ]
+    , label_
+        [ text "#" ]
+    , input
+        [ HP.value $ unwrap state.branch
+        , onValueInput
+            ( Just <<< SelectBranch
+            )
+        ]
+    ]
+
+handleQuery :: forall output a m. Query a -> H.HalogenM State Action () output m (Maybe a)
+handleQuery = case _ of
+  GetBranchObject reply -> do
+    branchObject <- H.get
+    pure (Just (reply branchObject))
+
+handleAction :: forall cs o m. Action → H.HalogenM State Action cs o m Unit
+handleAction = case _ of
+  SelectOwner owner' -> H.modify_ \st -> st { owner = wrap owner' }
+  SelectRepository repository' -> H.modify_ \st -> st { repository = wrap repository' }
+  SelectBranch branch' -> H.modify_ \st -> st { branch = wrap branch' }

src/Web/Main.purs

@@ -0,0 +1,14 @@
+module Web.Main where
+
+import Prelude
+import Effect (Effect)
+import Halogen.HTML
+import Halogen.Aff as HA
+import Halogen.VDom.Driver (runUI)
+import Web.Page.Home as Home
+
+main :: Effect Unit
+main =
+  HA.runHalogenAff do
+    body <- HA.awaitBody
+    runUI (Home.page) unit body

src/Web/Page/Home.purs

@@ -0,0 +1,90 @@
+module Web.Page.Home where
+
+import Halogen.HTML (HTML, button, div_, input, p_, slot, text)
+import Halogen.HTML.Events (onClick, onValueInput)
+import Prelude (Unit, Void, absurd, bind, discard, unit, void, ($), (<<<), (<>))
+import Control.Async (runAsync)
+import Control.Monad.Maybe.Trans (MaybeT(..), runMaybeT)
+import Data.Either (Either(..))
+import Data.Explain (explain)
+import Data.Maybe (Maybe(..))
+import Data.Symbol (SProxy(..))
+import Effect.Class (class MonadEffect)
+import Effect.Console as Console
+import Github.Api.Api (AccessToken(..))
+import Github.Entities (BranchObject, branchURI, canonicalBranch)
+import Github.Settings.BranchProtection (syncBranchProtectionSettings)
+import Halogen as H
+import Halogen.HTML.Properties as HP
+import Web.Component.RepositorySelector as RepositorySelector
+
+type Slots
+  = ( from :: H.Slot RepositorySelector.Query Void Int
+    , to :: H.Slot RepositorySelector.Query Void Int
+    )
+
+_from = SProxy :: SProxy "from"
+
+_to = SProxy :: SProxy "to"
+
+type State
+  = { from :: BranchObject
+    , to :: BranchObject
+    , accessToken :: String
+    }
+
+data Action
+  = SyncRepository
+  | SetAccessToken String
+
+page :: forall q i o m. MonadEffect m => H.Component HTML q i o m
+page =
+  H.mkComponent
+    { initialState:
+        \_ ->
+          { accessToken: ""
+          , from: canonicalBranch "" "" ""
+          , to: canonicalBranch "" "" ""
+          }
+    , render: render
+    , eval: H.mkEval $ H.defaultEval { handleAction = handleAction }
+    }
+
+render :: forall m. State -> H.ComponentHTML Action Slots m
+render state =
+  div_
+    [ p_ [ text $ "Access token" ]
+    , input
+        [ HP.value $ state.accessToken
+        , HP.type_ HP.InputPassword
+        , onValueInput (Just <<< SetAccessToken)
+        ]
+    , p_ [ text $ "from" ]
+    , slot _from 0 RepositorySelector.component unit absurd
+    , p_ [ text $ "to" ]
+    , slot _to 0 RepositorySelector.component unit absurd
+    , button
+        [ onClick \_ -> Just $ SyncRepository ]
+        [ text "Sync repo" ]
+    , p_ [ text $ (branchURI state.from) <> " -> " <> (branchURI state.to) ]
+    ]
+
+handleAction :: forall output m. MonadEffect m => Action → H.HalogenM State Action Slots output m Unit
+handleAction = case _ of
+  SyncRepository ->
+    void
+      $ runMaybeT do
+          accessToken <- H.gets _.accessToken
+          from <- MaybeT $ H.query _from 0 $ H.request RepositorySelector.GetBranchObject
+          to <- MaybeT $ H.query _to 0 $ H.request RepositorySelector.GetBranchObject
+          H.modify_ \state -> state { from = from, to = to }
+          H.liftEffect $ Console.log $ "Syncing stuff " <> accessToken
+          let
+            asyncAction = syncBranchProtectionSettings (AccessToken accessToken) from to
+
+            -- TODO: refactor Async into Aff and put this result in the state
+            resultCb result = case result of
+              Left err -> H.liftEffect $ Console.log $ "Some error " -- <> explain err
+              Right val -> H.liftEffect $ Console.log $ "Yeay: " <> explain val
+          H.liftEffect $ runAsync asyncAction resultCb
+  SetAccessToken token -> H.modify_ \state -> state { accessToken = token }

web/index.html

@@ -0,0 +1,10 @@
+<!DOCTYPE html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+    <title>Github repository sync</title>
+  </head>
+  <body>
+    <script src="./index.js"></script>
+  </body>
+</html>

web/index.js

@@ -0,0 +1 @@
+require('../output/Web.Main/index.js').main()