7 files changed, 533 insertions, 0 deletions

diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
new file mode 100644
index 0000000..dcfd402
--- /dev/null
+++ b/client/src/Util/Ajax.hs
@@ -0,0 +1,139 @@
+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
new file mode 100644
index 0000000..804b10f
--- /dev/null
+++ b/client/src/Util/Css.hs
@@ -0,0 +1,9 @@
+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
new file mode 100644
index 0000000..e76bc8a
--- /dev/null
+++ b/client/src/Util/Either.hs
@@ -0,0 +1,7 @@
+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
new file mode 100644
index 0000000..aa5cebb
--- /dev/null
+++ b/client/src/Util/Reflex.hs
@@ -0,0 +1,59 @@
+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
new file mode 100644
index 0000000..e9d0a1a
--- /dev/null
+++ b/client/src/Util/Router.hs
@@ -0,0 +1,266 @@
+{-# 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
new file mode 100644
index 0000000..50f2468
--- /dev/null
+++ b/client/src/Util/Validation.hs
@@ -0,0 +1,36 @@
+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
new file mode 100644
index 0000000..fe7b733
--- /dev/null
+++ b/client/src/Util/WaitFor.hs
@@ -0,0 +1,17 @@
+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)