packages feed

trasa-reflex (empty) → 0.1.0.0

raw patch · 6 files changed

+288/−0 lines, 6 filesdep +basedep +bytestringdep +containerssetup-changed

Dependencies added: base, bytestring, containers, ghcjs-dom, http-types, jsaddle, reflex, reflex-dom, text, trasa

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for trasa-reflex++## 0.1.0.0  -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2017 Kyle McKean++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Reflex/PopState.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall -Werror #-}+module Reflex.PopState (url) where++import qualified Data.Text as T+import Reflex.Class (Reflex(..),MonadHold(..),ffor)+import Reflex.PerformEvent.Class (PerformEvent(..))+import Reflex.TriggerEvent.Class (TriggerEvent)+import Reflex.Dom.Builder.Immediate (wrapDomEvent)+import Language.Javascript.JSaddle (eval,call)+import GHCJS.DOM (currentWindowUnchecked)+import GHCJS.DOM.Types (MonadJSM,liftJSM,ToJSVal(..))+import GHCJS.DOM.EventM (on)+import GHCJS.DOM.Window (getLocation)+import GHCJS.DOM.WindowEventHandlers (popState)+import GHCJS.DOM.Location (getPathname)+import Trasa.Core (Url,decodeUrl,encodeUrl)++getPopState :: (Reflex t, TriggerEvent t m, MonadJSM m) => m (Event t Url)+getPopState = do+  window <- currentWindowUnchecked+  wrapDomEvent window (`on` popState) $ do+    loc <- getLocation window+    locStr <- getPathname loc+    (return . decodeUrl) locStr++-- | The starting location and a stream of popstate urls+url :: (MonadHold t m, TriggerEvent t m, PerformEvent t m, MonadJSM (Performable m), MonadJSM m) =>+  Event t Url -> m (Url, Event t Url)+url us = do+  u0 <- liftJSM $ do+    window   <- currentWindowUnchecked+    loc <- getLocation window+    locStr   <- getPathname loc+    (return . decodeUrl) locStr+  performEvent_ $ ffor us $ \uri -> liftJSM $ do+    f <- eval ("(function (url) { window[\"history\"][\"pushState\"](0,\"\",url) })" :: T.Text)+    jsUri <- toJSVal (encodeUrl uri)+    _ <- call f f [jsUri]+    return ()+  ps <- getPopState+  return (u0, ps)
+ src/Trasa/Reflex.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wall -Werror #-}+module Trasa.Reflex+  ( requestWith+  , requestManyWith+  , ResponseHandler(..)+  , requestMultiWith+  , serve+  , Arguments+  , handler) where++import Data.Kind (Type)++import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS (toStrict,fromStrict)++import Data.Functor.Identity (Identity(..))+import Data.Foldable (toList)+import qualified Data.Map.Strict as M+import qualified Network.HTTP.Types.Status as N+import Reflex.Dom++import Trasa.Core hiding (requestWith,Arguments,handler)++import Reflex.PopState++-- | Replaces 'Trasa.Core.Arguments' with one that does not deal with request bodies+type family Arguments (caps :: [Type]) (qrys :: [Param]) (resp :: Type) (result :: Type) :: Type where+  Arguments '[] '[] resp result = resp -> result+  Arguments '[] (q:qs) resp result = ParamBase q -> Arguments '[] qs resp result+  Arguments (cap:caps) qs resp result = cap -> Arguments caps qs resp result++-- | "Trasa.Reflex.handler" is to "Trasa.Core.handler" as "Trasa.Reflex.Arguments" is to "Trasa.Core.Arguments"+handler :: Rec Identity caps -> Rec Parameter qrys -> ResponseBody Identity resp -> Arguments caps qrys resp x -> x+handler = go+  where+    go :: Rec Identity caps -> Rec Parameter qrys -> ResponseBody Identity resp -> Arguments caps qrys resp x -> x+    go RNil RNil (ResponseBody (Identity response)) f = f response+    go RNil (q :& qs) respBody f = go RNil qs respBody (f (demoteParameter q))+    go (Identity cap :& caps) qs respBody f = go caps qs respBody (f cap)++-- | Used when you want to perform an action for any response type+data ResponseHandler route a = forall resp. ResponseHandler+  !(Prepared route resp)+  !(ResponseBody (Many BodyDecoding) resp)+  !(resp -> a)++data Pair a b = Pair !a !b+  deriving (Functor, Foldable, Traversable)++newtype Preps route resp f a = Preps (f (Pair (ResponseHandler route resp) a))+  deriving (Functor,Foldable,Traversable)++-- | Single request version of 'requestManyWith'+requestWith :: forall t m route response.+  MonadWidget t m+  => (forall caps qrys req resp. route caps qrys req resp -> T.Text)+  -- ^+  -> (forall caps qrys req resp. route caps qrys req resp -> Path CaptureEncoding caps)+  -> (forall caps qrys req resp. route caps qrys req resp -> Rec (Query CaptureEncoding) qrys)+  -> (forall caps qrys req resp. route caps qrys req resp -> RequestBody (Many BodyEncoding) req)+  -> (forall caps qrys req resp. route caps qrys req resp -> ResponseBody (Many BodyDecoding) resp)+  -> Event t (Prepared route response)+  -> m (Event t (Either TrasaErr response))+requestWith toMethod toCapEncs toQuerys toReqBody toRespBody prepared =+  coerceEvent <$> requestManyWith toMethod toCapEncs toQuerys toReqBody toRespBody preparedId+  where preparedId = coerceEvent prepared :: Event t (Identity (Prepared route response))++-- | Perform n requests and collect the results+requestManyWith :: forall t m f route response.+  (MonadWidget t m, Traversable f)+  => (forall caps qrys req resp. route caps qrys req resp -> T.Text)+  -- ^ Get the method from a route+  -> (forall caps qrys req resp. route caps qrys req resp -> Path CaptureEncoding caps)+  -- ^ How to encode the path pieces from a route+  -> (forall caps qrys req resp. route caps qrys req resp -> Rec (Query CaptureEncoding) qrys)+  -- ^ How to encode the query parameters from a route+  -> (forall caps qrys req resp. route caps qrys req resp -> RequestBody (Many BodyEncoding) req)+  -- ^ How to encode the request body from a route+  -> (forall caps qrys req resp. route caps qrys req resp -> ResponseBody (Many BodyDecoding) resp)+  -- ^ How to decode a response from a route+  -> Event t (f (Prepared route response))+  -- ^ The routes to request+  -> m (Event t (f (Either TrasaErr response)))+requestManyWith toMethod toCapEncs toQuerys toReqBody toRespBody prepared =+  requestMultiWith toMethod toCapEncs toQuerys toReqBody toRespBody (fmap toResponseHandler <$> prepared)+  where toResponseHandler p@(Prepared route _ _ _) = ResponseHandler p (toRespBody route) id++-- | Internal function but exported because it subsumes the function of all the other functions in this package.+-- | Very powerful function+requestMultiWith :: forall t m f route a.+  (MonadWidget t m, Traversable f)+  => (forall caps qrys req resp. route caps qrys req resp -> T.Text)+  -> (forall caps qrys req resp. route caps qrys req resp -> Path CaptureEncoding caps)+  -> (forall caps qrys req resp. route caps qrys req resp -> Rec (Query CaptureEncoding) qrys)+  -> (forall caps qrys req resp. route caps qrys req resp -> RequestBody (Many BodyEncoding) req)+  -> (forall caps qrys req resp. route caps qrys req resp -> ResponseBody (Many BodyDecoding) resp)+  -> Event t (f (ResponseHandler route a))+  -> m (Event t (f (Either TrasaErr a)))+requestMultiWith toMethod toCapEncs toQuerys toReqBody toRespBody contResp =+  fmap parseXhrResponses <$> performRequestsAsync (buildXhrRequests <$> contResp)+  where parseXhrResponses :: Preps route a f XhrResponse -> f (Either TrasaErr a)+        parseXhrResponses (Preps res) = fmap parseOneXhrResponse res+        parseOneXhrResponse :: Pair (ResponseHandler route a) XhrResponse -> Either TrasaErr a+        parseOneXhrResponse (Pair (ResponseHandler (Prepared route _ _ _) _ fromResp)+                            (XhrResponse statusCode _ _ response headers)) =+          case statusCode < 400 of+            True -> case M.lookup "Content-Type" headers of+              Just content -> case response of+                Just txt -> let bs = LBS.fromStrict (TE.encodeUtf8 txt) in+                  case decodeResponseBody (toRespBody route) (Content content bs) of+                    Just a -> Right (fromResp a)+                    Nothing -> Left (TrasaErr N.status400 "Could not decode resp body")+                Nothing -> Left (TrasaErr N.status400 "No body returned from server")+              Nothing -> Left (TrasaErr N.status406 "No content type from server")+            False -> Left (TrasaErr (N.mkStatus (fromIntegral statusCode) (maybe "" TE.encodeUtf8 response)) "")+        buildXhrRequests :: f (ResponseHandler route a) -> Preps route a f (XhrRequest BS.ByteString)+        buildXhrRequests = Preps . fmap buildOneXhrRequest+        buildOneXhrRequest :: ResponseHandler route a -> Pair (ResponseHandler route a) (XhrRequest BS.ByteString)+        buildOneXhrRequest w@(ResponseHandler p@(Prepared route _ _ _) _ _) =+          Pair w (XhrRequest (toMethod route) (encodeUrl (linkWith toCapEncs toQuerys p)) conf)+          where conf :: XhrRequestConfig BS.ByteString+                conf = def & xhrRequestConfig_sendData .~ maybe "" (LBS.toStrict . contentData) content+                           & xhrRequestConfig_headers .~ headers+                           & xhrRequestConfig_responseHeaders .~ AllHeaders+                headers = maybe acceptHeader (\ct -> M.insert "Content-Type" (contentType ct) acceptHeader) content+                acceptHeader = "Accept" =: T.intercalate ", " (toList accepts)+                Payload _ content accepts = payloadWith toCapEncs toQuerys toReqBody toRespBody p++-- | Used to serve single page apps+serve :: forall t m route.+  MonadWidget t m+  => (forall caps qrys req resp. route caps qrys req resp -> T.Text)+  -> (forall caps qrys req resp. route caps qrys req resp -> Path CaptureEncoding caps)+  -> (forall caps qrys req resp. route caps qrys req resp -> Rec (Query CaptureCodec) qrys)+  -> (forall caps qrys req resp. route caps qrys req resp -> RequestBody (Many BodyCodec) req)+  -> (forall caps qrys req resp. route caps qrys req resp -> ResponseBody (Many BodyCodec) resp)+  -> Router route+  -> (forall caps qrys req resp.+      route caps qrys req resp ->+      Rec Identity caps ->+      Rec Parameter qrys ->+      ResponseBody Identity resp ->+      m (Event t (Concealed route)))+  -- ^ Build a widget from captures, query parameters, and a response body+  -> (TrasaErr -> m (Event t (Concealed route)))+  -> m ()+serve toMethod toCapEnc toQuerys toReqBody toRespBody router widgetize onErr = mdo+  -- Investigate why this is needed+  let newUrls = ffor (switch (current jumpsD)) $ \(Concealed route caps querys reqBody) ->+        linkWith toCapEnc toQueryEnc (Prepared route caps querys reqBody)+  (u0, urls) <- url newUrls+  pb <- getPostBuild+  let choice = ffor (leftmost [newUrls, urls, u0 <$ pb]) $ \us ->+        parseWith toQueryDec toReqBodyDec router "GET" us Nothing+      (failures, concealeds) = fanEither choice+  actions <- requestMultiWith toMethod toCapEnc toQueryEnc toReqBodyEnc toRespBodyDec (fromConcealed <$> concealeds)+  jumpsD <- widgetHold (return never) (leftmost [onErr <$> failures, either onErr id . runIdentity <$> actions])+  return ()+  where+    toQueryEnc :: route caps qrys req resp -> Rec (Query CaptureEncoding) qrys+    toQueryEnc = mapQuery captureCodecToCaptureEncoding . toQuerys+    toQueryDec :: route caps qrys req resp -> Rec (Query CaptureDecoding) qrys+    toQueryDec = mapQuery captureCodecToCaptureDecoding . toQuerys+    toReqBodyDec :: route caps qrys req resp -> RequestBody (Many BodyDecoding) req+    toReqBodyDec = mapRequestBody (mapMany bodyCodecToBodyDecoding) . toReqBody+    toReqBodyEnc :: route caps qrys req resp -> RequestBody (Many BodyEncoding) req+    toReqBodyEnc = mapRequestBody (mapMany bodyCodecToBodyEncoding) . toReqBody+    toRespBodyDec :: route caps qrys req resp -> ResponseBody (Many BodyDecoding) resp+    toRespBodyDec = mapResponseBody (mapMany bodyCodecToBodyDecoding) . toRespBody+    fromConcealed :: Concealed route -> Identity (ResponseHandler route (m (Event t (Concealed route))))+    fromConcealed (Concealed route caps querys reqBody) =+      Identity (ResponseHandler (Prepared route caps querys reqBody) (toRespBodyDec route)+               (widgetize route caps querys . ResponseBody . Identity))
+ trasa-reflex.cabal view
@@ -0,0 +1,33 @@+name:                trasa-reflex+version:             0.1.0.0+synopsis:            Reactive Type Safe Routing+license:             MIT+license-file:        LICENSE+author:              Kyle McKean+maintainer:          mckean.kylej@gmail.com+copyright:           @2017 Kyle McKean+category:            Text+build-type:          Simple+extra-source-files:  ChangeLog.md+cabal-version:       >=1.10+description:         Reflex-frp integration for trasa++library+  exposed-modules:     Reflex.PopState+                     , Trasa.Reflex+  build-depends:       base >=4.9 && <4.10+                     , bytestring == 0.10.*+                     , text == 1.2.*+                     , http-types == 0.9.*+                     , containers == 0.5.*+                     , jsaddle == 0.8.*+                     , ghcjs-dom > 0.7 && < 0.9+                     , reflex == 0.5.*+                     , reflex-dom == 0.4.*+                     , trasa == 0.1.*+  hs-source-dirs:      src+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/haskell-trasa/trasa