client.hs

{-# LANGUAGE DeriveGeneric, OverloadedStrings, RecursiveDo, ScopedTypeVariables, RankNTypes #-}

module Main where

import Control.Lens
import Data.Bifunctor (first)
import qualified Data.ByteString as BS
import Control.Monad.Except
import qualified Data.Text as T
import Data.Monoid
import GHC.Generics
import Reflex.Dom
import Reflex.Dom.Contrib.Router
import Text.Read (readMaybe)
import qualified Data.Text.Encoding as T
import Web.Routes.PathInfo
import qualified Web.Routes.PathInfo as WR
import qualified URI.ByteString as U

data MyType = Cat
            | Dog Int
  deriving (Eq, Show, Read,Generic)

instance PathInfo MyType

main :: IO ()
main = mainWidget run

webRoute
  :: (MonadWidget t m, WR.PathInfo a)
  => T.Text     -- ^ The part of the URL not related to SPA routing, starting with '/'
  -> Event t a
  -> m (Dynamic t (Either T.Text a))
webRoute pathBase aUpdates = do
  route' encoder decoder aUpdates
 where
   -- x = WR.fromPathInfo :: _
   encoder u a = u & U.pathL .~ T.encodeUtf8 (pathBase <> WR.toPathInfo a)
   decoder u = first T.pack . WR.fromPathInfo =<<
     note (pathBase <> " is a Bad prefix for " <> T.decodeUtf8 (U.serializeURIRef' u))
     (BS.stripPrefix (T.encodeUtf8 pathBase) (u ^. U.pathL))


note :: e -> Maybe a -> Either e a
note _ (Just a) = Right a
note e _ = Left e

run :: forall t m .MonadWidget t m => m ()
run = do
  pb <- getPostBuild
  bk <- button "back"
  fw <- button "forward"
  text "2"

  divClass "" $ mdo
    text "web"
    r :: Dynamic t (Either T.Text MyType) <- webRoute "/app" (fmapMaybe id $ tag (current vs) go)
    xs <- textInput def { _textInputConfig_setValue = (T.pack . show) <$>
                          fmapMaybe hush (traceEvent "wr Set" $
                                          leftmost [updated r
                                                   , tag (current r) pb]) }
    let vs :: Dynamic t (Maybe MyType) = traceDyn "vs" $ (readMaybe .   T.unpack) <$> value xs
    go <- button "Go"
    return ()


  divClass "" $ mdo
    text "pathinfo2"
    s <- partialPathRoute "app" (tag (current vs) ho)
    ys <- textInput def { _textInputConfig_setValue =
                                          leftmost [(T.intercalate "/" <$> updated s)
                                                   , (T.intercalate "/" <$> tag (current s) pb )
                                                   ] }
    let vs :: Dynamic t T.Text = traceDyn "ys" $ value ys
    ho <- button "Go"
    display s
    return ()



  return ()

hush :: Either e a -> Maybe a
hush (Right a) = Just a
hush _         = Nothing

server.hs

{-# language OverloadedStrings, DeriveGeneric, ScopedTypeVariables #-}
module Main where

import Data.Monoid
import Control.Applicative
import qualified Data.ByteString.Char8 as BS
import Snap.Http.Server
import Snap.Core
import Snap.Util.FileServe
import qualified Data.Text as T
import Web.Routes.PathInfo

data MyType = Cat
            | Dog Int
  deriving (Eq, Show, Read,Generic)

instance PathInfo MyType

sf :: MonadSnap m => BS.ByteString -> (BS.ByteString, m ())
sf fn = (fn, serveFile (BS.unpack fn))

main :: IO ()
main = quickHttpServe $
  (route $ map sf ["rts.js"
                  ,"lib.js"
                  ,"out.js"
                  ,"runmain.js"
                  ] ++ [("app", serveFile "index.html")])

indexHandler :: Snap ()
indexHandler = do
  r <- getRequest
  let pi = rqURI r
  case fromPathInfo pi :: Either String MyType of
    Left _ -> writeBS $ "Failed to match: " <> pi
    Right _ -> serveFile "index.html"