Skip to content

Instantly share code, notes, and snippets.

@agrafix
Created July 24, 2016 10:23
Show Gist options
  • Save agrafix/4e25f27b9684c9f28c9afbc4ce007d77 to your computer and use it in GitHub Desktop.
Save agrafix/4e25f27b9684c9f28c9afbc4ce007d77 to your computer and use it in GitHub Desktop.
Spock GHC+GHCJS APIs
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
module Api
( Endpoint(..)
, Proxy(..)
, MaybeToList
, (<//>), var, Path(..), renderRoute
, Generic, ToJSON, FromJSON, NFData, Typeable
)
where
import Data.Aeson
import Data.Proxy
import Data.HVect
import GHC.Generics
import Control.DeepSeq
import Data.Typeable
import Web.Routing.SafeRouting
type family MaybeToList (a :: Maybe *) :: [*] where
MaybeToList ('Just r) = '[r]
MaybeToList 'Nothing = '[]
(<//>) :: Path as -> Path bs -> Path (Append as bs)
(<//>) = (</>)
data Endpoint (p :: [*]) (i :: Maybe *) (o :: *) where
MethodGet :: (ToJSON o, FromJSON o) => Path p -> Endpoint p 'Nothing o
MethodPost :: (ToJSON i, FromJSON i, ToJSON o, FromJSON o) => Proxy (i -> o) -> Path p -> Endpoint p ('Just i) o
MethodPut :: (ToJSON i, FromJSON i, ToJSON o, FromJSON o) => Proxy (i -> o) -> Path p -> Endpoint p ('Just i) o
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module ApiClient
( callEndpoint )
where
import 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.Text as J
import qualified Data.Text.Encoding as T
callEndpoint ::
forall p i o. (HasRep (MaybeToList i), HasRep p)
=> Endpoint p i o -> HVectElim p (HVectElim (MaybeToList i) (IO (Maybe o)))
callEndpoint ep = HV.curry $ \hv -> HV.curry (callEndpointCore' ep hv)
data EndpointCall p i o
= EndpointCall
{ epc_point :: !(Endpoint p i o)
, epc_params :: !(HVect p)
, epc_body :: !(HVect (MaybeToList i))
}
callEndpointCore' ::
forall p i o. Endpoint p i o -> HVect p -> HVect (MaybeToList i) -> IO (Maybe o)
callEndpointCore' ep hv b = callEndpointCore (EndpointCall ep hv b)
callEndpointCore :: forall p i o. EndpointCall p i o -> IO (Maybe o)
callEndpointCore call =
case call of
EndpointCall (MethodPost Proxy path) 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")]
, reqWithCredentials = False
, reqData = StringData bodyText
}
runJsonReq req
EndpointCall (MethodPut Proxy path) 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")]
, reqWithCredentials = False
, reqData = StringData bodyText
}
runJsonReq req
EndpointCall (MethodGet path) params HNil ->
do let rt = J.textToJSString $ renderRoute path params
req =
Request
{ reqMethod = GET
, reqURI = rt
, reqLogin = Nothing
, reqHeaders = []
, 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
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
module ApiServer
( defEndpoint )
where
import Api
import Control.Monad.Trans
import Web.Spock
import Data.HVect
import qualified Data.HVect as HV
defEndpoint ::
forall p i o m ctx.
(MonadIO m, HasRep p)
=> Endpoint p i o
-> HVectElim p (HVectElim (MaybeToList i) (ActionCtxT ctx m o))
-> SpockCtxT ctx m ()
defEndpoint ep handler =
defEndpointCore (ep, step2)
where
step1 :: HVect p -> HVectElim (MaybeToList i) (ActionCtxT ctx m o)
step1 = HV.uncurry handler
step2 :: HVect p -> HVect (MaybeToList i) -> ActionCtxT ctx m o
step2 p = HV.uncurry (step1 p)
defEndpointCore ::
forall p i o m ctx.
(MonadIO m, HasRep p)
=> (Endpoint p i o, HVect p -> HVect (MaybeToList i) -> ActionCtxT ctx m o)
-> SpockCtxT ctx m ()
defEndpointCore t =
case t of
(MethodGet path, handler) ->
let pf :: HVect p -> ActionCtxT ctx m ()
pf args =
do r <- handler args HNil
json r
in get path (HV.curry pf)
(MethodPost _ path, handler) ->
let pf :: HVect p -> ActionCtxT ctx m ()
pf args =
do req <- jsonBody'
r <- handler args (req :&: HNil)
json r
in post path (HV.curry pf)
(MethodPut _ path, handler) ->
let pf :: HVect p -> ActionCtxT ctx m ()
pf args =
do req <- jsonBody'
r <- handler args (req :&: HNil)
json r
in put path (HV.curry pf)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment