Routing server and client

Client.hs

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

module Main where

import qualified Data.Text as T
import GHC.Generics
import Reflex.Dom
import Reflex.Dom.Contrib.Router
import Text.Read (readMaybe)
import Web.Routes.PathInfo

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

instance PathInfo MyType

main :: IO ()
main = mainWidget run

run :: forall t m .MonadWidget t m => m ()
run = mdo
  pb <- getPostBuild
  text "2"
  r :: Route t MyType <- webRoute def { _routeConfig_pushState = fmapMaybe id $ tag (current vs) go }
  xs <- textInput def { _textInputConfig_setValue = (T.pack . show) <$>
                         fmapMaybe hush (leftmost [updated (value r), tag (current $ value r) pb]) }
  let vs :: Dynamic t (Maybe MyType) = traceDyn "vs" $ (readMaybe . T.unpack) <$> value xs
  go <- button "Go"
  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"
                  ,"index.html"])
   <|> ifTop (serveFile "index.html")
   <|> indexHandler

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"