Skip to content

Commit cd2002b

Browse files
bitonicbitonic
committed
add ghcjs version of client library
1 parent 3cba1bd commit cd2002b

File tree

5 files changed

+275
-0
lines changed

5 files changed

+275
-0
lines changed

‎solga-client-ghcjs/LICENSE‎

Lines changed: 20 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,20 @@
1+
Copyright (c) 2017 Francesco Mazzoli
2+
3+
Permission is hereby granted, free of charge, to any person obtaining
4+
a copy of this software and associated documentation files (the
5+
"Software"), to deal in the Software without restriction, including
6+
without limitation the rights to use, copy, modify, merge, publish,
7+
distribute, sublicense, and/or sell copies of the Software, and to
8+
permit persons to whom the Software is furnished to do so, subject to
9+
the following conditions:
10+
11+
The above copyright notice and this permission notice shall be included
12+
in all copies or substantial portions of the Software.
13+
14+
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15+
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16+
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
17+
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
18+
CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
19+
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
20+
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

‎solga-client-ghcjs/Setup.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,2 @@
1+
import Distribution.Simple
2+
main = defaultMain

‎solga-client-ghcjs/solga-client-ghcjs.cabal‎

Lines changed: 25 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,25 @@
1+
name: solga-client-ghcjs
2+
version: 0.1.0.0
3+
synopsis: Simple typesafe web routing
4+
description: A library for easily making requests to solga endpoints
5+
license: MIT
6+
license-file: LICENSE
7+
author: Francesco Mazzoli
8+
maintainer: [email protected]
9+
copyright: Copyright (C) 2017 Francesco Mazzoli
10+
category: Web
11+
build-type: Simple
12+
homepage: https://github.com/chpatrick/solga
13+
bug-reports: https://github.com/chpatrick/solga/issues
14+
-- extra-source-files:
15+
cabal-version: >=1.10
16+
17+
library
18+
exposed-modules: Solga.Client.GHCJS
19+
build-depends: base >= 4.8 && < 5,
20+
solga-core,
21+
ghcjs-base,
22+
dlist
23+
hs-source-dirs: src
24+
default-language: Haskell2010
25+
ghc-options: -Wall

‎solga-client-ghcjs/src/Solga/Client/GHCJS.hs‎

Lines changed: 208 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,208 @@
1+
{-# LANGUAGE TypeFamilies #-}
2+
{-# LANGUAGE MultiParamTypeClasses #-}
3+
{-# LANGUAGE FlexibleInstances #-}
4+
{-# LANGUAGE ExistentialQuantification #-}
5+
{-# LANGUAGE FunctionalDependencies #-}
6+
{-# LANGUAGE ScopedTypeVariables #-}
7+
{-# LANGUAGE GADTs #-}
8+
{-# LANGUAGE DataKinds #-}
9+
{-# LANGUAGE TypeOperators #-}
10+
{-# LANGUAGE ScopedTypeVariables #-}
11+
{-# LANGUAGE RankNTypes #-}
12+
{-# LANGUAGE TypeInType #-}
13+
{-# LANGUAGE TypeApplications #-}
14+
{-# LANGUAGE LambdaCase #-}
15+
{-# LANGUAGE OverloadedStrings #-}
16+
{-# LANGUAGE DeriveGeneric #-}
17+
{-# LANGUAGE DefaultSignatures #-}
18+
{-# LANGUAGE FlexibleContexts #-}
19+
{-# LANGUAGE JavaScriptFFI #-}
20+
{-# LANGUAGE RecordWildCards #-}
21+
module Solga.Client.GHCJS where
22+
{-
23+
( Client(..)
24+
, SomeRequestData(..)
25+
, choose
26+
, RawRequest(..)
27+
, ToSegment(..)
28+
, WithData(..)
29+
, GetResponse(..)
30+
) where
31+
-}
32+
33+
import Data.Kind
34+
import Data.Proxy
35+
import GHC.Generics
36+
import GHC.TypeLits (symbolVal, KnownSymbol, Symbol)
37+
import Data.Monoid ((<>))
38+
import qualified JavaScript.Web.XMLHttpRequest as Xhr
39+
import Control.Exception (Exception, throwIO)
40+
import qualified Data.JSString as JSS
41+
import Data.JSString (JSString)
42+
import Data.Typeable (Typeable)
43+
import qualified Data.DList as DList
44+
import Data.DList (DList)
45+
import Data.String (fromString)
46+
import qualified JavaScript.JSON.Types.Class as Json
47+
import qualified JavaScript.JSON.Types.Internal as Json
48+
import GHCJS.Types (Immutable)
49+
50+
import Solga.Core hiding (Header)
51+
52+
data SomeRequestData out a = forall in_. (Client in_) => SomeRequestData (Proxy in_) (RequestData in_ a)
53+
54+
type Header = (JSString, JSString)
55+
56+
data Request = Request
57+
{ reqMethod :: String
58+
, reqHost :: JSString
59+
, reqSegments :: DList JSString
60+
, reqQueryString :: JSString
61+
, reqData :: Xhr.RequestData
62+
, reqLogin :: Maybe (JSString, JSString)
63+
, reqHeaders :: [Header]
64+
, reqWithCredentials :: Bool
65+
}
66+
67+
newtype BadMethod = BadMethod String
68+
deriving (Eq, Show, Typeable)
69+
instance Exception BadMethod
70+
71+
foreign import javascript unsafe
72+
"encodeURI($1)"
73+
js_encodeURI :: JSString -> IO JSString
74+
75+
toXhrRequest :: Request -> IO Xhr.Request
76+
toXhrRequest Request{..} = do
77+
meth <- case reqMethod of
78+
"GET" -> return Xhr.GET
79+
"POST" -> return Xhr.POST
80+
"PUT" -> return Xhr.PUT
81+
"DELETE" -> return Xhr.DELETE
82+
x -> throwIO (BadMethod x)
83+
uri <- js_encodeURI (reqHost <> "/" <> JSS.intercalate "/" (DList.toList reqSegments) <> reqQueryString)
84+
return Xhr.Request
85+
{ Xhr.reqMethod = meth
86+
, Xhr.reqURI = uri
87+
, Xhr.reqLogin = reqLogin
88+
, Xhr.reqHeaders = reqHeaders
89+
, Xhr.reqWithCredentials = reqWithCredentials
90+
, Xhr.reqData = reqData
91+
}
92+
93+
class Client r where
94+
type RequestData r :: * -> *
95+
type RequestData r = SomeRequestData r
96+
performRequest :: proxy r -> Request -> RequestData r a -> IO a
97+
default
98+
performRequest :: forall (proxy :: * -> *) a.
99+
(RequestData r ~ SomeRequestData r)
100+
=> proxy r -> Request -> RequestData r a -> IO a
101+
performRequest _p req (SomeRequestData p perf) = performRequest p req perf
102+
103+
choose :: forall in_ out a.
104+
(Client in_, RequestData out ~ SomeRequestData out)
105+
=> (out -> in_) -> RequestData in_ a -> RequestData out a
106+
choose _f perf = SomeRequestData (Proxy @in_) perf
107+
108+
newtype RawRequest a = RawRequest {unRequestDataRaw :: Request -> IO a}
109+
110+
instance Client (Raw a) where
111+
type RequestData (Raw a) = RawRequest
112+
performRequest _p req (RawRequest f) = f req
113+
114+
instance Client (RawResponse a) where
115+
type RequestData (RawResponse a) = RawRequest
116+
performRequest _p req (RawRequest f) = f req
117+
118+
instance (Client next) => Client (End next) where
119+
type RequestData (End next) = RequestData next
120+
performRequest _p req perf = performRequest (Proxy @next) req perf
121+
122+
addSegment :: Request -> JSString -> Request
123+
addSegment req seg = req{reqSegments = reqSegments req <> DList.singleton seg}
124+
125+
instance (Client next, KnownSymbol seg) => Client (Seg seg next) where
126+
type RequestData (Seg seg next) = RequestData next
127+
performRequest _p req perf =
128+
performRequest (Proxy @next) (addSegment req (fromString (symbolVal (Proxy @seg)))) perf
129+
130+
instance (Client left, Client right) => Client (left :<|> right) where
131+
type RequestData (left :<|> right) = RequestData left :+: RequestData right
132+
performRequest _p req = \case
133+
L1 perf -> performRequest (Proxy @left) req perf
134+
R1 perf -> performRequest (Proxy @right) req perf
135+
136+
data WhichSeg (segs :: [Symbol]) where
137+
ThisSeg :: KnownSymbol seg => WhichSeg (seg ': segs)
138+
ThatSeg :: WhichSeg segs -> WhichSeg (seg ': segs)
139+
140+
thisSeg :: forall seg segs. KnownSymbol seg => WhichSeg (seg ': segs) -> String
141+
thisSeg _ = symbolVal (Proxy @seg)
142+
143+
whichSeg :: WhichSeg segs -> String
144+
whichSeg ts@ThisSeg = thisSeg ts
145+
whichSeg (ThatSeg ws) = whichSeg ws
146+
147+
instance (Client next) => Client (OneOfSegs segs next) where
148+
type RequestData (OneOfSegs segs next) = WithData (WhichSeg segs) (RequestData next)
149+
performRequest _p req (WithData ws perf) =
150+
performRequest (Proxy @next) (addSegment req (fromString (whichSeg ws))) perf
151+
152+
class ToSegment a where
153+
toSegment :: a -> JSString
154+
155+
instance ToSegment JSString where
156+
toSegment = id
157+
158+
data WithData a next b = WithData
159+
{ ardData :: a
160+
, ardNext :: next b
161+
}
162+
163+
instance (Client next, ToSegment a) => Client (Capture a next) where
164+
type RequestData (Capture a next) = WithData a (RequestData next)
165+
performRequest _p req (WithData x perf) =
166+
performRequest (Proxy @next) (addSegment req (toSegment x)) perf
167+
168+
instance (Client next, KnownSymbol method) => Client (Method method next) where
169+
type RequestData (Method seg next) = RequestData next
170+
performRequest _p req perf = performRequest
171+
(Proxy @next) req{reqMethod = symbolVal (Proxy @method)} perf
172+
173+
newtype GetResponse resp a b = GetResponse {unGetResponse :: Xhr.Response resp -> a -> IO b}
174+
175+
instance (Json.FromJSON a) => Client (JSON a) where
176+
-- note that we do not decode eagerly because it's often the case that the body
177+
-- cannot be decoded since web servers return invalid json on errors
178+
-- (e.g. "Internal server error" on a 500 rather than a json encoded error)
179+
type RequestData (JSON a) = GetResponse (Json.SomeValue Immutable) (Maybe (Either String a))
180+
performRequest _p req (GetResponse f) = do
181+
resp <- Xhr.xhr =<< toXhrRequest req
182+
f resp $ do
183+
data_ <- Xhr.contents resp
184+
return (Json.parseEither Json.parseJSON data_)
185+
186+
instance (Client next) => Client (ExtraHeaders next) where
187+
type RequestData (ExtraHeaders next) = RequestData next
188+
performRequest _p req perf = performRequest (Proxy @next) req perf
189+
190+
instance (Client next) => Client (NoCache next) where
191+
type RequestData (NoCache next) = RequestData next
192+
performRequest _p req perf = performRequest (Proxy @next) req perf
193+
194+
instance (Client next, Json.ToJSON a) => Client (ReqBodyJSON a next) where
195+
type RequestData (ReqBodyJSON a next) = WithData a (RequestData next)
196+
performRequest _p req (WithData x perf) = performRequest
197+
(Proxy @next) req{reqData = Xhr.StringData (Json.encode (Json.toJSON x))} perf
198+
199+
instance (Client next) => Client (WithIO next) where
200+
type RequestData (WithIO next) = RequestData next
201+
performRequest _p req perf = performRequest (Proxy @next) req perf
202+
203+
instance (Client next) => Client (ReqBodyMultipart fp a next) where
204+
type
205+
RequestData (ReqBodyMultipart fp a next) =
206+
WithData [(JSString, Xhr.FormDataVal)] (RequestData next)
207+
performRequest _p req (WithData fd perf) = do
208+
performRequest (Proxy @next) req{reqData = Xhr.FormData fd} perf

‎stack-ghcjs.yaml‎

Lines changed: 20 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,20 @@
1+
packages:
2+
- 'solga-core'
3+
- 'solga-client-ghcjs'
4+
- location:
5+
git: [email protected]:bitonic/ghcjs-base.git
6+
commit: e36e6be8a99a240c51319abd36827cc00e0c3cf2
7+
extra-dep: true
8+
allow-newer: true
9+
flags: {}
10+
extra-package-dbs: []
11+
12+
resolver: lts-8.11
13+
compiler: ghcjs-0.2.1.9008011_ghc-8.0.2
14+
compiler-check: match-exact
15+
setup-info:
16+
ghcjs:
17+
source:
18+
ghcjs-0.2.1.9008011_ghc-8.0.2:
19+
url: https://github.com/matchwood/ghcjs-stack-dist/raw/master/ghcjs-0.2.1.9008011.tar.gz
20+
sha1: a72a5181124baf64bcd0e68a8726e65914473b3b

0 commit comments

Comments
 (0)