aboutsummaryrefslogtreecommitdiff
path: root/client/src/Util
diff options
context:
space:
mode:
Diffstat (limited to 'client/src/Util')
-rw-r--r--client/src/Util/Ajax.hs139
-rw-r--r--client/src/Util/Css.hs9
-rw-r--r--client/src/Util/Either.hs7
-rw-r--r--client/src/Util/Reflex.hs59
-rw-r--r--client/src/Util/Router.hs266
-rw-r--r--client/src/Util/Validation.hs36
-rw-r--r--client/src/Util/WaitFor.hs17
7 files changed, 0 insertions, 533 deletions
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)
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-01 08:52:54 +0000