diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013 - 2016, Alexander Thiemann + +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 Alexander Thiemann 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Spock-api-ghcjs.cabal b/Spock-api-ghcjs.cabal new file mode 100644 --- /dev/null +++ b/Spock-api-ghcjs.cabal @@ -0,0 +1,31 @@ +name: Spock-api-ghcjs +version: 0.11.0.0 +synopsis: Another Haskell web framework for rapid development +description: GHCJS client side wiring for Spock-api APIs +Homepage: https://www.spock.li +Bug-reports: https://github.com/agrafix/Spock/issues +license: BSD3 +license-file: LICENSE +author: Alexander Thiemann +maintainer: Alexander Thiemann +copyright: (c) 2013 - 2016 Alexander Thiemann +category: Web +build-type: Simple +cabal-version: >=1.8 + +library + hs-source-dirs: src + exposed-modules: Web.Spock.Api.Client + build-depends: + base >= 4 && < 5, + ghcjs-base, + aeson, + bytestring, + text, + Spock-api, + hvect >= 0.3.1 + ghc-options: -auto-all -Wall + +source-repository head + type: git + location: https://github.com/agrafix/Spock diff --git a/src/Web/Spock/Api/Client.hs b/src/Web/Spock/Api/Client.hs new file mode 100644 --- /dev/null +++ b/src/Web/Spock/Api/Client.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Web.Spock.Api.Client + ( callEndpoint, callEndpoint' ) +where + +import Web.Spock.Api + +import Data.HVect +import JavaScript.Web.XMLHttpRequest +import qualified Data.Aeson as A +import qualified Data.ByteString.Lazy as BSL +import qualified Data.HVect as HV +import qualified Data.JSString as J +import qualified Data.JSString.Text as J +import qualified Data.Text.Encoding as T + +type Header = (J.JSString, J.JSString) + +-- | Call an 'Endpoint' defined using the @Spock-api@ package passing extra headers +callEndpoint' :: + forall p i o. (HasRep (MaybeToList i), HasRep p) + => Endpoint p i o + -> [Header] + -> HVectElim p (HVectElim (MaybeToList i) (IO (Maybe o))) +callEndpoint' ep extraHeaders = + HV.curry $ \hv -> HV.curry (callEndpointCore' ep extraHeaders hv) + +-- | Call an 'Endpoint' defined using the @Spock-api@ package +callEndpoint :: + forall p i o. (HasRep (MaybeToList i), HasRep p) + => Endpoint p i o -> HVectElim p (HVectElim (MaybeToList i) (IO (Maybe o))) +callEndpoint ep = callEndpoint' ep [] + +data EndpointCall p i o + = EndpointCall + { epc_point :: !(Endpoint p i o) + , epc_headers :: ![Header] + , epc_params :: !(HVect p) + , epc_body :: !(HVect (MaybeToList i)) + } + +callEndpointCore' :: + forall p i o. + Endpoint p i o + -> [Header] + -> HVect p + -> HVect (MaybeToList i) + -> IO (Maybe o) +callEndpointCore' ep hdrs hv b = callEndpointCore (EndpointCall ep hdrs hv b) + +callEndpointCore :: forall p i o. EndpointCall p i o -> IO (Maybe o) +callEndpointCore call = + case call of + EndpointCall (MethodPost Proxy path) hdrs params (body :&: HNil) -> + do let rt = J.textToJSString $ renderRoute path params + bodyText = J.textToJSString $ T.decodeUtf8 $ BSL.toStrict $ A.encode body + req = + Request + { reqMethod = POST + , reqURI = rt + , reqLogin = Nothing + , reqHeaders = (("Content-Type", "application/json;charset=UTF-8") : hdrs) + , reqWithCredentials = False + , reqData = StringData bodyText + } + runJsonReq req + EndpointCall (MethodPut Proxy path) hdrs params (body :&: HNil) -> + do let rt = J.textToJSString $ renderRoute path params + bodyText = J.textToJSString $ T.decodeUtf8 $ BSL.toStrict $ A.encode body + req = + Request + { reqMethod = PUT + , reqURI = rt + , reqLogin = Nothing + , reqHeaders = (("Content-Type", "application/json;charset=UTF-8") : hdrs) + , reqWithCredentials = False + , reqData = StringData bodyText + } + runJsonReq req + EndpointCall (MethodGet path) hdrs params HNil -> + do let rt = J.textToJSString $ renderRoute path params + req = + Request + { reqMethod = GET + , reqURI = rt + , reqLogin = Nothing + , reqHeaders = hdrs + , reqWithCredentials = False + , reqData = NoData + } + runJsonReq req + +runJsonReq :: A.FromJSON o => Request -> IO (Maybe o) +runJsonReq req = + do response <- xhrText req + case (status response, contents response) of + (200, Just txt) -> + do let res = A.eitherDecodeStrict' (T.encodeUtf8 txt) + case res of + Left errMsg -> + do putStrLn errMsg + pure Nothing + Right val -> + pure (Just val) + _ -> pure Nothing