From 11052951b74b9ad4b6a9412ae490086235f9154b Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 3 Jan 2021 13:40:40 +0100
Subject: Rewrite in Rust

---
 client/src/Util/Ajax.hs       | 139 ----------------------
 client/src/Util/Css.hs        |   9 --
 client/src/Util/Either.hs     |   7 --
 client/src/Util/Reflex.hs     |  59 ----------
 client/src/Util/Router.hs     | 266 ------------------------------------------
 client/src/Util/Validation.hs |  36 ------
 client/src/Util/WaitFor.hs    |  17 ---
 7 files changed, 533 deletions(-)
 delete mode 100644 client/src/Util/Ajax.hs
 delete mode 100644 client/src/Util/Css.hs
 delete mode 100644 client/src/Util/Either.hs
 delete mode 100644 client/src/Util/Reflex.hs
 delete mode 100644 client/src/Util/Router.hs
 delete mode 100644 client/src/Util/Validation.hs
 delete mode 100644 client/src/Util/WaitFor.hs

(limited to 'client/src/Util')

diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
deleted file mode 100644
index dcfd402..0000000
--- a/client/src/Util/Ajax.hs
+++ /dev/null
@@ -1,139 +0,0 @@
-module Util.Ajax
-  ( getNow
-  , get
-  , post
-  , postAndParseResult
-  , put
-  , putAndParseResult
-  , delete
-  ) where
-
-import           Control.Arrow        (left)
-import           Data.Aeson           (FromJSON, ToJSON)
-import qualified Data.Aeson           as Aeson
-import           Data.ByteString      (ByteString)
-import qualified Data.ByteString.Lazy as LBS
-import           Data.Default         (def)
-import qualified Data.Map.Lazy        as LM
-import           Data.Text            (Text)
-import qualified Data.Text            as T
-import qualified Data.Text.Encoding   as T
-import           Data.Time.Clock      (NominalDiffTime)
-import           Reflex.Dom           (Dynamic, Event, IsXhrPayload,
-                                       MonadWidget, XhrRequest,
-                                       XhrRequestConfig (..), XhrResponse,
-                                       XhrResponseHeaders (..))
-import qualified Reflex.Dom           as R
-
-import           Loadable             (Loadable)
-import qualified Loadable
-
-getNow :: forall t m a. (MonadWidget t m, FromJSON a) => Text -> m (Dynamic t (Loadable a))
-getNow url = do
-  postBuild <- R.getPostBuild
-  get (url <$ postBuild)
-    >>= R.debounce (0 :: NominalDiffTime) -- Fired 2 times otherwise
-    >>= Loadable.fromEvent
-
-get
-  :: forall t m a. (MonadWidget t m, FromJSON a)
-  => Event t Text
-  -> m (Event t (Either Text a))
-get url =
-  fmap getJsonResult <$>
-    R.performRequestAsync (R.ffor url $ \u -> jsonRequest "GET" u (Aeson.String ""))
-
-post
-  :: forall t m a. (MonadWidget t m, ToJSON a)
-  => Text
-  -> Event t a
-  -> m (Event t (Either Text ()))
-post url input =
-  fmap checkResult <$>
-    R.performRequestAsync (jsonRequest "POST" url <$> input)
-
-postAndParseResult
-  :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b)
-  => Text
-  -> Event t a
-  -> m (Event t (Either Text b))
-postAndParseResult url input =
-  fmap getJsonResult <$>
-    R.performRequestAsync (jsonRequest "POST" url <$> input)
-
-put
-  :: forall t m a. (MonadWidget t m, ToJSON a)
-  => Text
-  -> Event t a
-  -> m (Event t (Either Text ()))
-put url input =
-  fmap checkResult <$>
-    R.performRequestAsync (jsonRequest "PUT" url <$> input)
-
-putAndParseResult
-  :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b)
-  => Text
-  -> Event t a
-  -> m (Event t (Either Text b))
-putAndParseResult url input =
-  fmap getJsonResult <$>
-    R.performRequestAsync (jsonRequest "PUT" url <$> input)
-
-delete
-  :: forall t m a. (MonadWidget t m)
-  => Dynamic t Text
-  -> Event t ()
-  -> m (Event t (Either Text Text))
-delete url fire = do
-  fmap getResult <$>
-    (R.performRequestAsync $
-      R.attachWith (\u _ -> request "DELETE" u ()) (R.current url) fire)
-
-checkResult :: XhrResponse -> Either Text ()
-checkResult response =
-  () <$ getResult response
-
-getJsonResult :: forall a. (FromJSON a) => XhrResponse -> Either Text a
-getJsonResult response =
-  case getResult response of
-    Left l  -> Left l
-    Right r -> left T.pack . Aeson.eitherDecodeStrict $ (T.encodeUtf8 r)
-
-getResult :: XhrResponse -> Either Text Text
-getResult response =
-  case R._xhrResponse_responseText response of
-    Just responseText ->
-      if R._xhrResponse_status response == 200
-        then Right responseText
-        else Left responseText
-    _ -> Left "NoKey"
-
-request :: forall a. (IsXhrPayload a) => Text -> Text -> a -> XhrRequest a
-request method url payload =
-  let
-    config = XhrRequestConfig
-      { _xhrRequestConfig_headers = def
-      , _xhrRequestConfig_user = def
-      , _xhrRequestConfig_password = def
-      , _xhrRequestConfig_responseType = def
-      , _xhrRequestConfig_responseHeaders = def
-      , _xhrRequestConfig_withCredentials = False
-      , _xhrRequestConfig_sendData = payload
-      }
-  in
-    R.xhrRequest method url config
-
-jsonRequest :: forall a. (ToJSON a) => Text -> Text -> a -> XhrRequest ByteString
-jsonRequest method url payload =
-  let
-    config = XhrRequestConfig
-      { _xhrRequestConfig_headers = def
-      , _xhrRequestConfig_user = def
-      , _xhrRequestConfig_password = def
-      , _xhrRequestConfig_responseType = def
-      , _xhrRequestConfig_responseHeaders = def
-      , _xhrRequestConfig_withCredentials = False
-      , _xhrRequestConfig_sendData = LBS.toStrict $ Aeson.encode payload
-      }
-  in
-    R.xhrRequest method url config
diff --git a/client/src/Util/Css.hs b/client/src/Util/Css.hs
deleted file mode 100644
index 804b10f..0000000
--- a/client/src/Util/Css.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-module Util.Css
-  ( classes
-  ) where
-
-import           Data.Text (Text)
-import qualified Data.Text as T
-
-classes :: [(Text, Bool)] -> Text
-classes = T.unwords . map fst . filter snd
diff --git a/client/src/Util/Either.hs b/client/src/Util/Either.hs
deleted file mode 100644
index e76bc8a..0000000
--- a/client/src/Util/Either.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module Util.Either
-  ( eitherToMaybe
-  ) where
-
-eitherToMaybe :: forall a b. Either a b -> Maybe b
-eitherToMaybe (Right b) = Just b
-eitherToMaybe _         = Nothing
diff --git a/client/src/Util/Reflex.hs b/client/src/Util/Reflex.hs
deleted file mode 100644
index aa5cebb..0000000
--- a/client/src/Util/Reflex.hs
+++ /dev/null
@@ -1,59 +0,0 @@
-module Util.Reflex
-  ( visibleIfDyn
-  , visibleIfEvent
-  , divVisibleIf
-  , divClassVisibleIf
-  , flatten
-  , flattenTuple
-  , getBody
-  ) where
-
-import qualified Data.Map                 as M
-import           Data.Text                (Text)
-import qualified GHCJS.DOM                as Dom
-import qualified GHCJS.DOM.Document       as Document
-import qualified GHCJS.DOM.HTMLCollection as HTMLCollection
-import           GHCJS.DOM.Types          (Element)
-import           Reflex.Dom               (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom               as R
-
-visibleIfDyn :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a -> m (Event t a)
-visibleIfDyn cond empty content =
-  R.dyn $ R.ffor cond $ \case
-    True -> content
-    False -> empty
-
-visibleIfEvent :: forall t m a. MonadWidget t m => Event t Bool -> m a -> m a -> m (Dynamic t a)
-visibleIfEvent cond empty content =
-  R.widgetHold empty $
-    R.ffor cond $ \case
-      True -> content
-      False -> empty
-
-divVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a
-divVisibleIf cond content = divClassVisibleIf cond "" content
-
-divClassVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> Text -> m a -> m a
-divClassVisibleIf cond className content =
-  R.elDynAttr
-    "div"
-    (fmap (\c -> (M.singleton "class" className) `M.union` if c then M.empty else M.singleton "style" "display:none") cond)
-    content
-
-flatten :: forall t m a. MonadWidget t m => Event t (Event t a) -> m (Event t a)
-flatten e = do
-  dyn <- R.holdDyn R.never e
-  return $ R.switchDyn dyn
-
-flattenTuple
-  :: forall t m a b. MonadWidget t m
-  => Event t (Event t a, Event t b)
-  -> m (Event t a, Event t b)
-flattenTuple e = (,) <$> (flatten $ fmap fst e) <*> (flatten $ fmap snd e)
-
-getBody :: forall t m. MonadWidget t m => m Element
-getBody = do
-  document <- Dom.currentDocumentUnchecked
-  nodelist <- Document.getElementsByTagName document ("body" :: String)
-  Just body <- nodelist `HTMLCollection.item` 0
-  return body
diff --git a/client/src/Util/Router.hs b/client/src/Util/Router.hs
deleted file mode 100644
index e9d0a1a..0000000
--- a/client/src/Util/Router.hs
+++ /dev/null
@@ -1,266 +0,0 @@
-{-# LANGUAGE CPP                      #-}
-{-# LANGUAGE ConstraintKinds          #-}
-{-# LANGUAGE FlexibleContexts         #-}
-{-# LANGUAGE ForeignFunctionInterface #-}
-{-# LANGUAGE JavaScriptFFI            #-}
-{-# LANGUAGE LambdaCase               #-}
-{-# LANGUAGE OverloadedStrings        #-}
-{-# LANGUAGE RankNTypes               #-}
-{-# LANGUAGE RecursiveDo              #-}
-{-# LANGUAGE ScopedTypeVariables      #-}
-{-# LANGUAGE TemplateHaskell          #-}
-{-# LANGUAGE TypeFamilies             #-}
-
-module Util.Router (
-  -- == High-level routers
-    route
-  , route'
-  , partialPathRoute
-
-  -- = Low-level URL bar access
-  , getLoc
-  , getURI
-  , getUrlText
-  , uriOrigin
-  , URI
-
-  -- = History movement
-  , goForward
-  , goBack
-  ) where
-
-------------------------------------------------------------------------------
-import           Control.Lens                  ((&), (.~), (^.))
-import           Control.Monad.Fix             (MonadFix)
-import qualified Data.ByteString.Char8         as BS
-import           Data.Monoid                   ((<>))
-import           Data.Text                     (Text)
-import qualified Data.Text                     as T
-import qualified Data.Text.Encoding            as T
-import           GHCJS.DOM                     (currentDocumentUnchecked,
-                                                currentWindowUnchecked)
-import           GHCJS.DOM.Document            (createEvent)
-import           GHCJS.DOM.Event               (initEvent)
-import           GHCJS.DOM.EventM              (on)
-import           GHCJS.DOM.EventTarget         (dispatchEvent_)
-import           GHCJS.DOM.History             (History, back, forward,
-                                                pushState)
-import           GHCJS.DOM.Location            (getHref)
-import           GHCJS.DOM.PopStateEvent
-import           GHCJS.DOM.Types               (Location (..),
-                                                PopStateEvent (..))
-import           GHCJS.DOM.Types               (MonadJSM, uncheckedCastTo)
-import qualified GHCJS.DOM.Types               as DOM
-import           GHCJS.DOM.Window              (getHistory, getLocation)
-import           GHCJS.DOM.WindowEventHandlers (popState)
-import           GHCJS.Foreign                 (isFunction)
-import           GHCJS.Marshal.Pure            (pFromJSVal)
-import           Language.Javascript.JSaddle   (JSM, Object (..), ghcjsPure,
-                                                liftJSM)
-import qualified Language.Javascript.JSaddle   as JS
-import           Reflex.Dom.Core               hiding (EventName, Window)
-import qualified URI.ByteString                as U
-------------------------------------------------------------------------------
-
-
--------------------------------------------------------------------------------
--- | Manipulate and track the URL 'GHCJS.DOM.Types.Location' for dynamic
---   routing of a widget
---   These sources of URL-bar change will be reflected in the output URI
---     - Input events to 'route'
---     - Browser Forward/Back button clicks
---     - forward/back javascript calls (or 'goForward'/'goBack') Haskell calls
---     - Any URL changes followed by a popState event
---   But external calls to pushState that don't manually fire a popState
---   won't be detected
-route
- :: forall t m.
-  ( MonadHold t m
-  , PostBuild t m
-  , TriggerEvent t m
-  , PerformEvent t m
-  , HasJSContext m
-  , HasJSContext (Performable m)
-  , MonadJSM m
-  , MonadJSM (Performable m))
-  => Event t T.Text
-  -> m (Dynamic t (U.URIRef U.Absolute))
-route pushTo = do
-  loc0    <- getURI
-
-  _ <- performEvent $ ffor pushTo $ \t -> do
-    let newState = Just t
-    withHistory $ \h -> pushState h (0 :: Double) ("" :: T.Text) (newState :: Maybe T.Text)
-    liftJSM dispatchEvent'
-
-  locUpdates <- getPopState
-  holdDyn loc0 locUpdates
-
-route'
- :: forall t m a b.
-  ( MonadHold t m
-  , PostBuild t m
-  , TriggerEvent t m
-  , PerformEvent t m
-  , HasJSContext m
-  , HasJSContext (Performable m)
-  , MonadJSM m
-  , MonadJSM (Performable m)
-  , MonadFix m)
-  => (URI -> a -> URI)
-  -> (URI -> b)
-  -> Event t a
-  -> m (Dynamic t b)
-route' encode decode routeUpdate = do
-  rec rUri <- route (T.decodeUtf8 . U.serializeURIRef' <$> urlUpdates)
-      let urlUpdates = attachWith encode (current rUri) routeUpdate
-  return $ decode <$> rUri
-
-
--------------------------------------------------------------------------------
--- | Route a single page app according to the part of the path after
---   pathBase
-partialPathRoute
- :: forall t m.
-  ( MonadHold t m
-  , PostBuild t m
-  , DomBuilder t m
-  , TriggerEvent t m
-  , PerformEvent t m
-  , HasJSContext m
-  , HasJSContext (Performable m)
-  , MonadJSM m
-  , MonadJSM (Performable m)
-  , MonadFix m)
-  => T.Text  -- ^ The path segments not related to SPA routing
-             --   (leading '/' will be added automaticaly)
-  -> Event t T.Text -- ^ Updates to the path segments used for routing
-                    --   These values will be appended to the base path
-  -> m (Dynamic t [T.Text]) -- ^ Path segments used for routing
-partialPathRoute pathBase pathUpdates = do
-  route' (flip updateUrl) parseParts pathUpdates
-  where
-
-    rootPathBase :: T.Text
-    rootPathBase =
-      if T.null pathBase then
-        ""
-      else
-        "/" <> cleanT pathBase
-
-    toPath :: T.Text -> BS.ByteString
-    toPath dynpath = T.encodeUtf8 $ rootPathBase <> "/" <> cleanT dynpath
-
-    updateUrl :: T.Text -> URI -> URI
-    updateUrl updateParts u = u & U.pathL .~ toPath updateParts
-
-    parseParts :: URI -> [T.Text]
-    parseParts u =
-      maybe (error $ pfxErr u pathBase)
-            (T.splitOn "/" . T.decodeUtf8 . cleanB) .
-      BS.stripPrefix (T.encodeUtf8 $ cleanT pathBase) $
-      cleanB (u ^. U.pathL)
-
-    cleanT = T.dropWhile (=='/')
-    cleanB = BS.dropWhile (== '/')
-
-
--------------------------------------------------------------------------------
-uriOrigin :: U.URIRef U.Absolute -> T.Text
-uriOrigin r = T.decodeUtf8 $ U.serializeURIRef' r'
-  where
-    r' = r { U.uriPath = mempty
-           , U.uriQuery = mempty
-           , U.uriFragment = mempty
-           }
-
-
--------------------------------------------------------------------------------
-getPopState
- :: forall t m.
-  ( MonadHold t m
-  , TriggerEvent t m
-  , MonadJSM m) => m (Event t URI)
-getPopState = do
-  window <- currentWindowUnchecked
-  wrapDomEventMaybe window (`on` popState) $ do
-    loc <- getLocation window
-    locStr <- getHref loc
-    return . hush $ U.parseURI U.laxURIParserOptions (T.encodeUtf8 locStr)
-
-
--------------------------------------------------------------------------------
-goForward :: (HasJSContext m, MonadJSM m) => m ()
-goForward = withHistory forward
-
-
--------------------------------------------------------------------------------
-goBack :: (HasJSContext m, MonadJSM m) => m ()
-goBack = withHistory back
-
-
--------------------------------------------------------------------------------
-withHistory :: (HasJSContext m, MonadJSM m) => (History -> m a) -> m a
-withHistory act = do
-  w <- currentWindowUnchecked
-  h <- getHistory w
-  act h
-
-
--------------------------------------------------------------------------------
--- | (Unsafely) get the 'GHCJS.DOM.Location.Location' of a window
-getLoc :: (HasJSContext m, MonadJSM m) => m Location
-getLoc = do
-  win <- currentWindowUnchecked
-  loc <- getLocation win
-  return loc
-
-
--------------------------------------------------------------------------------
--- | (Unsafely) get the URL text of a window
-getUrlText :: (HasJSContext m, MonadJSM m) => m T.Text
-getUrlText = getLoc >>= getHref
-
-
--------------------------------------------------------------------------------
-type URI = U.URIRef U.Absolute
-
-
--------------------------------------------------------------------------------
-getURI :: (HasJSContext m, MonadJSM m) => m URI
-getURI = do
-  l <- getUrlText
-  return $ either (error "No parse of window location") id .
-    U.parseURI U.laxURIParserOptions $ T.encodeUtf8 l
-
-
-dispatchEvent' :: JSM ()
-dispatchEvent' = do
-  window <- currentWindowUnchecked
-  obj@(Object o) <- JS.create
-  JS.objSetPropertyByName obj ("cancelable" :: Text) True
-  JS.objSetPropertyByName obj ("bubbles" :: Text) True
-  JS.objSetPropertyByName obj ("view" :: Text) window
-  event <- JS.jsg ("PopStateEvent" :: Text) >>= ghcjsPure . isFunction >>= \case
-    True -> newPopStateEvent ("popstate" :: Text) $ Just $ pFromJSVal o
-    False -> do
-      doc <- currentDocumentUnchecked
-      event <- createEvent doc ("PopStateEvent" :: Text)
-      initEvent event ("popstate" :: Text) True True
-      JS.objSetPropertyByName obj ("view" :: Text) window
-      return $ uncheckedCastTo PopStateEvent event
-
-  dispatchEvent_ window event
-
-
--------------------------------------------------------------------------------
-hush :: Either e a -> Maybe a
-hush (Right a) = Just a
-hush _         = Nothing
-
-
--------------------------------------------------------------------------------
-pfxErr :: URI -> T.Text -> String
-pfxErr pn pathBase =
-  T.unpack $ "Encountered path (" <> T.decodeUtf8 (U.serializeURIRef' pn)
-            <> ") without expected prefix (" <> pathBase <> ")"
diff --git a/client/src/Util/Validation.hs b/client/src/Util/Validation.hs
deleted file mode 100644
index 50f2468..0000000
--- a/client/src/Util/Validation.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-module Util.Validation
-  ( nelError
-  , toMaybe
-  , maybeError
-  , fireValidation
-  ) where
-
-import           Control.Monad      (join)
-import           Data.List.NonEmpty (NonEmpty)
-import qualified Data.List.NonEmpty as NEL
-import           Data.Text          (Text)
-import           Data.Validation    (Validation (Failure, Success))
-import qualified Data.Validation    as Validation
-import           Reflex.Dom         (Dynamic, Event, Reflex)
-import qualified Reflex.Dom         as R
-
-nelError :: Validation a b -> Validation (NonEmpty a) b
-nelError = Validation.validation (Failure . NEL.fromList . (:[])) Success
-
-toMaybe :: Validation a b -> Maybe b
-toMaybe (Success s) = Just s
-toMaybe (Failure _) = Nothing
-
-maybeError :: Validation a b -> Maybe a
-maybeError (Success _) = Nothing
-maybeError (Failure e) = Just e
-
-fireValidation
-  :: forall t a b c. Reflex t
-  => Dynamic t (Validation a b)
-  -> Event t c
-  -> Event t b
-fireValidation value validate =
-  R.fmapMaybe
-    (Validation.validation (const Nothing) Just)
-    (R.tag (R.current value) validate)
diff --git a/client/src/Util/WaitFor.hs b/client/src/Util/WaitFor.hs
deleted file mode 100644
index fe7b733..0000000
--- a/client/src/Util/WaitFor.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-module Util.WaitFor
-  ( waitFor
-  ) where
-
-import           Data.Time  (NominalDiffTime)
-import           Reflex.Dom (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom as R
-
-waitFor
-  :: forall t m a b. MonadWidget t m
-  => (Event t a -> m (Event t b))
-  -> Event t a
-  -> m (Event t b, Event t Bool)
-waitFor op input = do
-  result <- op input >>= R.debounce (0.5 :: NominalDiffTime)
-  let waiting = R.leftmost [ True <$ input , False <$ result ]
-  return (result, waiting)
-- 
cgit v1.2.3