Spock GHC+GHCJS APIs

Api.hs

{-# 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

ApiClient.hs

{-# 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

ApiServer.hs

{-# 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)