diff --git a/rfc.cabal b/rfc.cabal --- a/rfc.cabal +++ b/rfc.cabal @@ -1,5 +1,5 @@ name: rfc -version: 0.0.0.22 +version: 0.0.0.23 synopsis: Robert Fischer's Common library description: An enhanced Prelude and various utilities for Aeson, Servant, PSQL, and Redis that Robert Fischer uses. homepage: https://github.com/RobertFischer/rfc#README.md @@ -20,8 +20,8 @@ Flag Development Description: Turn on errors for warnings - Default: False - Manual: True + Default: False + Manual: True library hs-source-dirs: src @@ -39,9 +39,6 @@ , string-conversions , resource-pool , data-default - , servant-blaze >= 0.8 - , blaze-html - , url , lens , http-types , http-api-data >= 0.3.7.1 @@ -56,6 +53,8 @@ , monad-control >= 1.0.2.2 , freer-simple >= 1.0.1.1 , natural-transformation >= 0.4 + , url + , network-uri if flag(Browser) build-depends: aeson , attoparsec @@ -65,6 +64,8 @@ build-depends: servant-server >= 0.13 , servant >= 0.13 , servant-docs >= 0.11.2 + , servant-blaze >= 0.8 + , blaze-html , wai >= 3.2.1.1 , aeson >= 1.2.3.0 , wai-extra @@ -98,6 +99,7 @@ , RFC.Miso.String , RFC.Miso.XHR , RFC.Miso.Inject + , RFC.Miso.Routing if !flag(Browser) exposed-modules: RFC.Psql , RFC.Redis diff --git a/src/RFC/HTTP/Client.hs b/src/RFC/HTTP/Client.hs --- a/src/RFC/HTTP/Client.hs +++ b/src/RFC/HTTP/Client.hs @@ -12,7 +12,6 @@ , BadStatusException , apiGet , module Network.Wreq.Session - , module Network.URL , module Network.HTTP.Types.Status ) where @@ -21,7 +20,7 @@ newManager) import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Types.Status hiding (statusCode, statusMessage) -import Network.URL +import Network.URI import Network.Wreq.Lens import Network.Wreq.Session hiding (withAPISession) import RFC.JSON (FromJSON, decodeOrDie) @@ -37,12 +36,12 @@ withAPISession :: (MonadIO m) => (Session -> m a) -> m a withAPISession = (>>=) $ (liftIO $ newSessionControl Nothing rfcManagerSettings) -newtype BadStatusException = BadStatusException (Status,URL) +newtype BadStatusException = BadStatusException (Status,URI) deriving (Show,Eq,Ord,Generic,Typeable) instance Exception BadStatusException apiExecute :: (HasAPIClient m, MonadUnliftIO m, ConvertibleString LazyByteString s) => - URL -> (Session -> String -> IO (Response LazyByteString)) -> (s -> m a) -> m a + URI -> (Session -> String -> IO (Response LazyByteString)) -> (s -> m a) -> m a apiExecute rawUrl action converter = do session <- getAPIClient response <- liftIO $ action session url @@ -51,10 +50,10 @@ 200 -> converter . cs $ response ^. responseBody _ -> throwIO $ badResponseStatus status where - url = exportURL rawUrl + url = show rawUrl badResponseStatus status = BadStatusException (status, rawUrl) -apiGet :: (HasAPIClient m, FromJSON a, MonadUnliftIO m, Exception e) => URL -> (e -> m a) -> m a +apiGet :: (HasAPIClient m, FromJSON a, MonadUnliftIO m, Exception e) => URI -> (e -> m a) -> m a apiGet url onError = handle onError $ apiExecute url get decodeOrDie diff --git a/src/RFC/Miso/Routing.hs b/src/RFC/Miso/Routing.hs new file mode 100644 --- /dev/null +++ b/src/RFC/Miso/Routing.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module RFC.Miso.Routing + ( module RFC.Miso.Routing + , URI(..) + ) where + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Proxy +import Miso.Effect +import Miso.Html (View (..)) +import Miso.Subscription.History (URI (..), getCurrentURI) +import qualified Network.URL as URL +import RFC.Prelude + +newtype URIHash = URIHash String deriving (Eq) +newtype URIQuery = URIQuery (Map String [String]) deriving (Eq) +type RoutingURI = (URIHash, URIQuery) + +parseURI :: URI -> RoutingURI +parseURI URI{uriFragment,uriQuery} = + (URIHash $ parseHash uriFragment, URIQuery $ parseQuery uriQuery) + where + parseHash ('#':rest) = parseHash rest + parseHash ('!':rest) = parseHash rest + parseHash ('/':rest) = parseHash rest + parseHash hash = hash + parseQuery :: String -> Map String [String] + parseQuery ('?':rest) = parseQuery rest + parseQuery query = + case URL.importParams query of + Nothing -> + Map.empty + Just pairs -> + Map.map sort $ Map.fromListWith (++) $ map (second listify) pairs + listify :: String -> [String] + listify "" = [] + listify val = [val] + +parseCurrentURI :: IO (URIHash,URIQuery) +parseCurrentURI = parseURI <$> getCurrentURI + +data ViewSpec parentModel parentAction = ViewSpec (parentModel -> View parentAction, RoutingURI) + +instance Eq (ViewSpec model action) where + (==) (ViewSpec(_,left)) (ViewSpec(_,right)) = left == right + +class (Typeable model) => RouteConfig model action + | model -> action, action -> model + where + routeUpdate :: model -> action -> Effect action model + routeView :: model -> View action + runRoute :: RoutingURI -> Maybe (Effect action model) + +class (RouteConfig model action) => RouteConvert parentModel parentAction model action + | parentAction -> parentModel, parentModel -> parentAction + where + wrapAction :: action -> model -> parentAction + unwrapAction :: parentAction -> model -> Maybe action + wrapModel :: parentModel -> model -> parentModel + unwrapModel :: parentModel -> model + wrapEffect :: parentModel -> Effect action model -> Effect parentAction parentModel + wrapEffect parentModel (Effect model childIOs) = + Effect + (wrapModel parentModel model) + (map (fmap (\act -> wrapAction act model)) childIOs) + + wrappedRunRoute :: Proxy model -> WrappedRun parentModel parentAction + wrappedRunRoute _ uriPair currentParentModel = do + childEffect <- runRoute uriPair + return (effectWrapper childEffect, ViewSpec (view, uriPair)) + where + effectWrapper :: Effect action model -> Effect parentAction parentModel + effectWrapper = wrapEffect currentParentModel + view :: parentModel -> View parentAction + view parentModel = fmap (\action -> wrapAction action childModel) $ routeView childModel + where + childModel :: model + childModel = unwrapModel parentModel + + wrappedRouteUpdate :: Proxy model -> WrappedUpdate parentModel parentAction + wrappedRouteUpdate _ parentModel parentAction = + case unwrapAction parentAction model of + Nothing -> noEff parentModel + Just action -> wrapEffect parentModel $ routeUpdate model action + where + model :: model + model = unwrapModel parentModel + +type WrappedRun parentModel parentAction = + RoutingURI -> parentModel -> Maybe (Effect parentAction parentModel, ViewSpec parentModel parentAction) + +type WrappedUpdate parentModel parentAction = parentModel -> parentAction -> Effect parentAction parentModel + +data RoutingTable parentModel parentAction = + RoutingTable [(WrappedRun parentModel parentAction, WrappedUpdate parentModel parentAction)] + +addRoute :: (RouteConvert parentModel parentAction model action) => + RoutingTable parentModel parentAction -> Proxy model -> RoutingTable parentModel parentAction +addRoute (RoutingTable table) pxy = + RoutingTable $ (wrappedRunRoute pxy, wrappedRouteUpdate pxy):table + +runTable :: + RoutingTable parentModel parentAction -> + (parentModel -> View parentAction) -> + RoutingURI -> + parentModel -> + (Effect parentAction parentModel, ViewSpec parentModel parentAction) +runTable (RoutingTable routes) notFoundView routingURI parentModel = + case safeHead $ catMaybes routeRunResults of + Nothing -> (noEff parentModel, ViewSpec (notFoundView, routingURI)) + Just results -> results + where + routeRunResults = map (\run -> run routingURI parentModel) $ map fst routes + +updateTable :: + RoutingTable parentModel parentAction -> + parentModel -> + parentAction -> + Effect parentAction parentModel +updateTable (RoutingTable tbl) initialParentModel parentAction = + foldr doMerge initialEffect updateCalls + where + initialEffect = Effect initialParentModel [] + updateCalls = map snd tbl + doMerge call (Effect parentModel ios) = + let (Effect newParentModel moreIOs) = call parentModel parentAction in + Effect newParentModel (ios++moreIOs) + +