react-flux-servant (empty) → 0.1.0

raw patch · 6 files changed

+367/−0 lines, 6 filesdep +aesondep +basedep +ghcjs-basesetup-changed

Dependencies added: aeson, base, ghcjs-base, react-flux, servant, text

Files

• ChangeLog.md +3/−0
• LICENSE +30/−0
• README.md +15/−0
• Setup.hs +2/−0
• react-flux-servant.cabal +44/−0
• src/React/Flux/Addons/Servant.hs +273/−0

@@ -0,0 +1,3 @@+# 0.1.0++* Initial release.  See the haddock for documentation.

@@ -0,0 +1,30 @@+Copyright (c) 2016, John Lenz++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of John Lenz nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,15 @@+This project integrates [react-flux](http://hackage.haskell.org/package/react-flux) with+[servant](http://hackage.haskell.org/package/servant).  There is a small example in the+haddock documentation.  To depend on this module, I add it to the `extra-deps` in my+project's `stack.yaml`.  See the [react-flux](http://hackage.haskell.org/package/react-flux)+documentation for a full example `stack.yaml`.++At the moment the code works well and is straightforward to integrate into a react-flux+store; I am using it in production.  Having said that, the current API requires you+to create two store actions for each request and it is somewhat tedious to write all+this boilerplate.  At some point, I would like to build a better API, perhaps one that+takes better advantage of the type-level Servant.API definitions to drastically reduce+the boilerplate.  Unfortunately, since it currently works (and even works well, the existing+API is good), due to time constraints it might be awhile before I get around to thinking about+better APIs.  If you have any ideas for a better API, even if you don't have any code,+please open an issue!

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,44 @@+name:                react-flux-servant+version:             0.1.0+synopsis:            Allow react-flux stores to send requests to a servant server+category:            Web+homepage:            https://bitbucket.org/wuzzeb/react-flux-servant+license:             BSD3+license-file:        LICENSE+author:              John Lenz <wuzzeb@gmail.com>+maintainer:          John Lenz <wuzzeb@gmail.com>+build-type:          Simple+description:         See the README below.+cabal-version:       >=1.10++extra-source-files:+    ChangeLog.md,+    README.md++source-repository head+    type: mercurial+    location: https://bitbucket.org/wuzzeb/react-flux-servant++library+  hs-source-dirs: src+  ghc-options: -Wall+  default-language: Haskell2010+  exposed-modules: React.Flux.Addons.Servant++  default-extensions: CPP+                      TypeOperators+                      DataKinds+                      PolyKinds+                      TypeFamilies+                      FlexibleInstances+                      OverloadedStrings+                      ScopedTypeVariables++  build-depends: base >=4.8 && < 5+               , react-flux >= 1.2 && < 1.3+               , servant >= 0.7+               , aeson >= 0.8+               , text >= 1.2++  if impl(ghcjs)+      build-depends: ghcjs-base

@@ -0,0 +1,273 @@+-- | Make calls to an API defined using "Servant.API" from your "React.Flux" stores.+-- __You must call 'initAjax' from your main function for this to work.__+-- For now, this module only works with JSON.+--+-- The general pattern I currently use is to create a store action to trigger the request+-- and another store action to process the response.  Only the store action to trigger+-- the request is exported.  This does lead to a bit of tedious boilerplate since you need+-- actions for each request, so I am still searching for a better API that perhaps takes+-- advantage of the servant API type-level computation to reduce the boilerplate.  For now,+-- until I figure out a better way, this direct approach does work.  If you have any ideas+-- for a good API, please open an issue on bitbucket (even if you don't have full code)!+--+-- As an example, say that the API consists of two methods:+--+-- @+-- type GetUser = "user" :> Capture "user_id" UserId :> Get '[JSON] User+-- type SetUser = "user" :> Capture "user_id" UserId :> ReqBody '[JSON] User :> Post '[JSON] ()+-- type MyAPI = GetUser :\<|\> SetUser+-- @+--+-- I would create a store as follows:+--+-- @+-- data RequestStatus = NoPendingRequest | PendingRequest | PreviousRequestHadError String+--+-- data UserStore = UserStore+--   { users :: Map.HashMap UserId User+--   , reqStatus :: RequestStatus+--   }+--+-- data UserStoreAction = RequestUser UserId+--                      | RequestUserResponse UserId (Either (Int,String) User)+--                      | UpdateUser UserId User+--                      | UpdateUserResponse UserId (Either (Int, String) ())+--   deriving (Show, Generic, NFData)+--+-- cfg :: ApiRequestConfig MyAPI+-- cfg = ApiRequestConfig "https://www.example.com" NoTimeout+--+-- instance StoreData UserStore where+--   type StoreAction UserStore = UserStoreAction+--+--   transform (RequestUser uid) us = do+--     request cfg (Proxy :: Proxy GetUser) uid $+--       \\r -> return [SomeStoreAction userStore $ RequestUserResponse uid r]+--     return $ us {reqStatus = PendingRequest}+--+--   transform (RequestUserResponse _ (Left (_errCode, err))) us =+--     return $ us {reqStatus = PreviousRequestHadError err}+--+--   transform (RequestUserResponse uid (Right u)) us =+--     return $ us { reqStatus = NoPendingRequest+--                 , users = Map.insert uid u (users us)+--                 }+--+--   transform (UpdateUser uid u) us = do+--     request cfg (Proxy :: Proxy SetUser) uid u $+--       \\r -> return [SomeStoreAction userStore $ UpdateUserResponse uid r]+--     return $ us { reqStatus = PendingRequest+--                 , users = Map.insert uid u (users us)+--                 }+--+--   transform (UpdateUserResponse uid (Left (_errCode, err))) us =+--     return $ us { reqStatus = PreviousRequestHadError err+--                 , users = Map.delete uid (users us)+--                 }+--+--   transform (UpdateUserResponse _ (Right ())) us =+--     return $ us { reqStatus = NoPendingRequest}+--+-- userStore :: ReactStore UserStore+-- userStore = mkStore $ UserStore Map.empty NoPendingRequest+-- @+module React.Flux.Addons.Servant(+    HandleResponse+  , RequestTimeout(..)+  , ApiRequestConfig(..)+  , request+  , HasAjaxRequest(..)+) where++import React.Flux+import React.Flux.Ajax+import Servant.Utils.Links+import Servant.API+import GHC.TypeLits+import Data.Typeable (Proxy(..))+import Data.Aeson+import Data.Monoid ((<>))+import qualified Data.Text as T+import qualified Data.Text.Encoding as T++#ifdef __GHCJS__+import Data.JSString (JSString)+import GHCJS.Types (JSVal, nullRef)+import GHCJS.Marshal (toJSVal_aeson, FromJSVal(..))+import Data.JSString.Text (textToJSString)+import qualified Data.JSString as JSS++jsPack :: String -> JSString+jsPack = JSS.pack+jsUnpack :: JSString -> String+jsUnpack = JSS.unpack+jsIntercalate :: JSString -> [JSString] -> JSString+jsIntercalate = JSS.intercalate++#else+import Data.List (intercalate)+type JSVal = ()+type JSString = String++nullRef :: JSVal+nullRef = ()++jsPack :: String -> JSString+jsPack = id++jsUnpack :: JSString -> String+jsUnpack = id++jsIntercalate :: JSString -> [JSString] -> JSString+jsIntercalate = intercalate++textToJSString :: T.Text -> JSString+textToJSString = T.unpack++fromJSVal :: JSVal -> IO a+fromJSVal = undefined++toJSVal_aeson :: a -> IO JSString+toJSVal_aeson = undefined++#endif++-- | Internal state used when building the request.+data Request = Request {+    segments :: [JSString]+  , rHeaders :: [(JSString, JSString)]+  , rQuery :: [(JSString, JSString)]+  , rBody :: IO JSVal+  , rTimeout :: RequestTimeout+}++-- | When a response from the server arrives, it is either an error or a valid response.  An error+-- is turned into a 'Left' value consisting of the HTTP response code and the response body.  If+-- a 200 HTTP response is received, it is parsed to a value according to the servant API definition+-- and passed as a 'Right' value.  You must then turn the response into a store action.  I suggest+-- that you just pass the value along directly to a store action without any computation; the computation+-- can happen inside the store.+type HandleResponse a = Either (Int,String) a -> IO [SomeStoreAction]++-- | Settings for requests built using this module.+data ApiRequestConfig api = ApiRequestConfig+    { urlPrefix :: JSString+    -- ^ A prefix for all requests; it should include the domain and any prefix path that is required.+    -- To this prefix a forward slash is appended and then the path built using the Servant API definition.+    , timeout :: RequestTimeout+    -- ^ The timeout to use for requests.  If a timeout occurs, a 'Left' value with code 504 is passed to+    -- 'HandleResponse'.+    }++-- | Make a request to a servant endpoint. __You must call 'initAjax' from your main function for this to work.__+--+-- 'request' takes the 'ApiRequestConfig', a proxy for the endpoint,+-- parameters for the request (request body, query params, path captures, etc.), and value of type 'HandleResponse'.+-- The result of 'request' is then a value of type @IO ()@.  In order to type-check that the proper values for+-- the request body, path captures, etc. are passed, the 'MkRequest' associated type is used.  'MkRequest' expands+-- to a function with one argument for each path piece and an argument for the 'HandleResponse'.  For example,+--+-- @+-- type GetUser = "user" :> Capture "user_id" UserId :> Get '[JSON] User+-- type SetUser = "user" :> Capture "user_id" UserId :> ReqBody '[JSON] User :> Post '[JSON] ()+-- type MyAPI = GetUser :\<|\> SetUser+-- @+--+-- Then+--+-- @+-- MkRequest GetUser ~ UserId -> HandleResponse User -> IO ()+-- MkRequest SetUser ~ UserId -> User -> HandleResponse () -> IO ()+-- @+--+-- so that+--+-- @+-- request cfg (Proxy :: Proxy GetUser) :: UserId -> HandleResponse User -> IO ()+-- request cfg (Proxy :: Proxy SetUser) :: UserId -> User -> HandleResponse () -> IO ()+-- @+request :: (IsElem endpoint api, HasAjaxRequest endpoint) => ApiRequestConfig api -> Proxy endpoint -> MkRequest endpoint+request (ApiRequestConfig p t) endpoint = toRequest endpoint (Request [p] [] [] (pure nullRef) t)++-- | A class very similar to "Servant.Utils.Links".  You shouldn't need to use this class directly: instead+-- use 'request'.  Having said that, the 'MkRequest' type defined in this typeclass is important as it determines+-- what values you must pass to 'request' to obtain a proper request.+class HasAjaxRequest endpoint where+    type MkRequest endpoint+    toRequest :: Proxy endpoint -> Request -> MkRequest endpoint++instance (ToJSON a, HasAjaxRequest sub) => HasAjaxRequest (ReqBody '[JSON] a :> sub) where+    type MkRequest (ReqBody '[JSON] a :> sub) = a -> MkRequest sub+    toRequest _ r body = toRequest (Proxy :: Proxy sub) (r+        { rBody = toJSVal_aeson body >>= js_JSONstringify+        , rHeaders = rHeaders r ++ [("Content-Type", "application/json")]+        })++instance (KnownSymbol sym, HasAjaxRequest sub) => HasAjaxRequest (sym :> sub) where+    type MkRequest (sym :> sub) = MkRequest sub+    toRequest _ r = toRequest (Proxy :: Proxy sub) (r { segments = segments r ++ [seg]})+        where+            seg = jsPack $ symbolVal (Proxy :: Proxy sym)++instance (ToHttpApiData v, HasAjaxRequest sub) => HasAjaxRequest (Capture sym v :> sub) where+    type MkRequest (Capture sym v :> sub) = v -> MkRequest sub+    toRequest _ r v = toRequest (Proxy :: Proxy sub) (r { segments = segments r ++ [v'] })+        where+            v' = jsPack $ T.unpack $ toUrlPiece v++instance (KnownSymbol sym, ToHttpApiData a, HasAjaxRequest sub) => HasAjaxRequest (Header sym a :> sub) where+    type MkRequest (Header sym a :> sub) = Maybe a -> MkRequest sub+    toRequest _ r Nothing  = toRequest (Proxy :: Proxy sub) r+    toRequest _ r (Just a) = toRequest (Proxy :: Proxy sub) (r { rHeaders = rHeaders r ++ [(sym',a')]})+        where+            sym' = jsPack $ symbolVal (Proxy :: Proxy sym)+            a' = jsPack $ T.unpack $ toUrlPiece a++instance (KnownSymbol sym, ToHttpApiData a, HasAjaxRequest sub) => HasAjaxRequest (QueryParam sym a :> sub) where+    type MkRequest (QueryParam sym a :> sub) = Maybe a -> MkRequest sub+    toRequest _ r Nothing = toRequest (Proxy :: Proxy sub) r+    toRequest _ r (Just a) = toRequest (Proxy :: Proxy sub) r { rQuery = rQuery r ++ [(sym', a')]}+        where+            sym' = jsPack $ symbolVal (Proxy :: Proxy sym)+            a' = jsPack $ T.unpack $ toUrlPiece a++instance (ReflectMethod m, FromJSON a) => HasAjaxRequest (Verb m s '[JSON] a) where+    type MkRequest (Verb m s '[JSON] a) = HandleResponse a -> IO ()+    toRequest _ r handler = do+        body <- rBody r+        let query :: JSString = case rQuery r of+                        [] -> ""+                        qs -> "?" <> jsIntercalate "&" (map (\(x,y) -> x <> "=" <> y) qs)+        let req = AjaxRequest+                  { reqMethod = textToJSString $ T.decodeUtf8 $ reflectMethod (Proxy :: Proxy m)+                  , reqURI = jsIntercalate "/" (segments r) <> query+                  , reqHeaders = rHeaders r ++ [("Accept", "application/json")]+                  , reqBody = body+                  , reqTimeout = rTimeout r+                  }+        ajax req $ \resp ->+            if respStatus resp == 200+                then do+                    j <- js_JSONParse $ respResponseText resp+                    mv <- fromJSVal j+                    case mv of+                        Nothing -> handler $ Left (500, "Unable to convert response body")+                        Just v -> case fromJSON v of+                            Success v' -> handler $ Right v'+                            Error e -> handler $ Left (500, e)+                else handler $ Left (respStatus resp, jsUnpack $ respResponseText resp)++#ifdef __GHCJS__+foreign import javascript unsafe+    "JSON['parse']($1)"+    js_JSONParse :: JSString -> IO JSVal++foreign import javascript unsafe+    "JSON['stringify']($1)"+    js_JSONstringify :: JSVal -> IO JSVal+#else+js_JSONParse :: JSString -> IO JSVal+js_JSONParse _ = return ()+js_JSONstringify :: JSString -> IO JSVal+js_JSONstringify _ = return ()+#endif