rfc 0.0.0.22 → 0.0.0.23
raw patch · 3 files changed
+148/−12 lines, 3 filesdep +network-uri
Dependencies added: network-uri
Files
- rfc.cabal +8/−6
- src/RFC/HTTP/Client.hs +5/−6
- src/RFC/Miso/Routing.hs +135/−0
rfc.cabal view
@@ -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
src/RFC/HTTP/Client.hs view
@@ -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
+ src/RFC/Miso/Routing.hs view
@@ -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)++