servant-subscriber (empty) → 0.1.0.0
raw patch · 15 files changed
+1263/−0 lines, 15 filesdep +aesondep +aeson-compatdep +asyncsetup-changed
Dependencies added: aeson, aeson-compat, async, attoparsec, base, base-compat, blaze-builder, blaze-html, blaze-markup, bytestring, case-insensitive, containers, directory, filepath, hspec, http-media, http-types, lens, lifted-base, lucid, monad-control, monad-logger, mtl, network-uri, purescript-bridge, servant, servant-foreign, servant-server, servant-subscriber, stm, string-conversions, text, time, transformers, wai, wai-websockets, warp, websockets
Files
- LICENSE +30/−0
- Readme.md +23/−0
- Setup.hs +2/−0
- app/PSGenerator.hs +37/−0
- servant-subscriber.cabal +97/−0
- src/Lib.hs +149/−0
- src/Servant/Subscriber.hs +61/−0
- src/Servant/Subscriber/Backend.hs +34/−0
- src/Servant/Subscriber/Backend/Wai.hs +77/−0
- src/Servant/Subscriber/Client.hs +202/−0
- src/Servant/Subscriber/Request.hs +69/−0
- src/Servant/Subscriber/Response.hs +107/−0
- src/Servant/Subscriber/Subscribable.hs +90/−0
- src/Servant/Subscriber/Types.hs +160/−0
- test/Spec.hs +125/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Robert Klotzner (c) 2016++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 Robert Klotzner 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.
+ Readme.md view
@@ -0,0 +1,23 @@+Servant Subscriber+==================++[](https://travis-ci.org/eskimor/servant-subscriber)++Servant-subscriber enables you clients to subscribe to resources in your servant-api (an API endpoint).+Servant-subscriber will then notify the client via a WebSocket connection whenever the resource+changes, thus the client can easily stay up to date all the time.++## Status++It seems to work - it is already tested in examples/central-counter of servant-purescript.++Still missing:++ - Client code generation with servant-purescript for subscriptions.+ - Client side code (purescript-subscriber) currently only contains a very low-level API which+ is also about to change.+ - Documentation, blog post.+ - Tests++I will now continue with my actual project which uses servant-subscriber and add the missing parts when+they come along.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/PSGenerator.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}++import Data.Proxy (Proxy (..))+import Language.PureScript.Bridge+import Language.PureScript.Bridge.PSTypes+import Servant.Subscriber.Request+import Servant.Subscriber.Response+import Servant.Subscriber.Types+++myTypes = [+ mkSumType (Proxy :: Proxy Request)+ , mkSumType (Proxy :: Proxy HttpRequest)+ , mkSumType (Proxy :: Proxy Response)+ , mkSumType (Proxy :: Proxy HttpResponse)+ , mkSumType (Proxy :: Proxy Status)+ , mkSumType (Proxy :: Proxy RequestError)+ , mkSumType (Proxy :: Proxy Path)+ ]++bridgeResponseBody :: BridgePart+bridgeResponseBody = do+ typeName ^== "ResponseBody"+ typeModule ^== "Servant.Subscriber.Response"+ return psString -- For now++bridgeRequestBody :: BridgePart+bridgeRequestBody = do+ typeName ^== "RequestBody"+ typeModule ^== "Servant.Subscriber.Request"+ return psString++myBridge :: BridgePart+myBridge = bridgeResponseBody <|> bridgeRequestBody <|> defaultBridge++main :: IO ()+main = writePSTypes "../purescript-subscriber/src" (buildBridge myBridge) myTypes
+ servant-subscriber.cabal view
@@ -0,0 +1,97 @@+name: servant-subscriber+version: 0.1.0.0+synopsis: Initial project template from stack+description: Please see Readme.md+homepage: http://github.com/eskimor/servant-subscriber#readme+license: BSD3+license-file: LICENSE+author: Robert Klotzner+maintainer: robert Dot klotzner A T gmx Dot at+copyright: Copyright: (c) 2016 Robert Klotzner+category: Web+build-type: Simple+extra-source-files: Readme.md+cabal-version: >=1.10++extra-source-files: Readme.md++library+ hs-source-dirs: src+ exposed-modules: Lib+ , Servant.Subscriber+ , Servant.Subscriber.Backend+ , Servant.Subscriber.Backend.Wai+ , Servant.Subscriber.Client+ , Servant.Subscriber.Request+ , Servant.Subscriber.Response+ , Servant.Subscriber.Subscribable+ , Servant.Subscriber.Types+ build-depends: aeson >= 0.11.2 && < 0.12+ , async+ , attoparsec+ , base >= 4.7 && < 5+ , blaze-builder+ , bytestring+ , case-insensitive+ , containers+ , directory >= 1.2.2.0+ , filepath+ , http-types+ , lens+ , lifted-base+ , monad-control+ , monad-logger+ , network-uri+ , servant+ , servant-foreign+ , servant-server+ , stm+ , text+ , time+ , transformers+ , wai+ , wai-websockets+ , warp+ , websockets+ default-language: Haskell2010++executable psGenerator+ hs-source-dirs: app+ main-is: PSGenerator.hs+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends: base+ , servant-subscriber+ , purescript-bridge >= 0.6 && < 0.7+ default-language: Haskell2010++test-suite servant-subscriber-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends:+ aeson+ , aeson-compat+ , attoparsec >= 0.13.0.1+ , base+ , base-compat >= 0.9.0+ , blaze-html >= 0.8.1.1+ , blaze-markup >= 0.7.0.3+ , bytestring >= 0.10.6.0+ , directory >= 1.2.2.0+ , http-media >= 0.6.3+ , lucid+ , mtl >= 2.2.1+ , servant-foreign+ , servant-server+ , servant-subscriber+ , string-conversions >= 0.4+ , time >= 1.5.0.1+ , wai+ , warp+ , hspec+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/eskimor/servant-subscriber
+ src/Lib.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+module Lib where+++import Control.Monad.Trans.Except (ExceptT)+import Data.Proxy+import GHC.Exts (Constraint)+import GHC.TypeLits+import Network.Wai (Application)+import Servant.API hiding (IsElem)+import Servant.Server+import Servant.Utils.Links hiding (IsElem, Or)+++++-- | Select a handler from an API by specifying a type level link.+-- | The value of this function is the selected handler which can be called.+callHandler :: forall api endpoint. (GetEndpoint api endpoint (PickLeftRight endpoint api))+ => Proxy api+ -> ServerT api (ExceptT ServantErr IO)+ -> Proxy endpoint+ -> ServerT endpoint (ExceptT ServantErr IO)+callHandler pA handlers pE = getEndpoint (Proxy :: Proxy (PickLeftRight endpoint api)) pM pA pE handlers+ where+ pM = Proxy :: Proxy (ExceptT ServantErr IO)++type family Or (a :: Bool) (b :: Bool) :: Bool where+ Or 'False 'False = 'False+ Or 'False 'True = 'True+ Or 'True 'False = 'True+ Or 'True 'True = 'True++type family And (a :: Bool) (b :: Bool) :: Bool where+ And 'False 'False = 'False+ And 'False 'True = 'False+ And 'True 'False = 'False+ And 'True 'True = 'True++type family Not (a :: Bool) :: Bool where+ Not 'False = 'True+ Not 'True = 'False++type family IsElem endpoint api :: Bool where+ IsElem e (sa :<|> sb) = Or (IsElem e sa) (IsElem e sb)+ IsElem (e :> sa) (e :> sb) = IsElem sa sb+ IsElem (Header sym :> sa) (Header sym x :> sb)+ = IsElem sa sb+ IsElem (ReqBody y x :> sa) (ReqBody y x :> sb)+ = IsElem sa sb+ IsElem (Capture z y :> sa) (Capture x y :> sb)+ = IsElem sa sb+ IsElem (QueryParam x y :> sa) (QueryParam x y :> sb)+ = IsElem sa sb+ IsElem (QueryParams x y :> sa) (QueryParams x y :> sb)+ = IsElem sa sb+ IsElem (QueryFlag x :> sa) (QueryFlag x :> sb)+ = IsElem sa sb+ IsElem (Verb m s ct typ) (Verb m s ct' typ)+ = IsSubList ct ct'+ IsElem e e = True+ IsElem sa sb = False++type family IsSubList a b :: Bool where+ IsSubList '[] b = True+ IsSubList (x ': xs) y = Elem x y `And` IsSubList xs y++type family Elem e es :: Bool where+ Elem x (x ': xs) = True+ Elem y (x ': xs) = Elem y xs+ Elem y '[] = False++type family EnableConstraint (c :: Constraint) (enable :: Bool) :: Constraint where+ EnableConstraint c 'True = c+ EnableConstraint c 'False = ()+++type family PickLeftRight endpoint api :: Bool where+ PickLeftRight endpoint (sa :<|> sb) = IsElem endpoint sb+ PickLeftRight endpoint sa = 'True++++class GetEndpoint api endpoint (chooseRight :: Bool) where+ getEndpoint :: forall m. Proxy chooseRight -> Proxy m -> Proxy api -> Proxy endpoint -> ServerT api m -> ServerT endpoint m++-- Left choice+instance (GetEndpoint b1 endpoint (PickLeftRight endpoint b1)) => GetEndpoint (b1 :<|> b2) endpoint 'False where+ getEndpoint _ pM _ pEndpoint (lS :<|> _) = getEndpoint pLeftRight pM (Proxy :: Proxy b1) pEndpoint lS+ where pLeftRight = Proxy :: Proxy (PickLeftRight endpoint b1)++-- Right choice+instance (GetEndpoint b2 endpoint (PickLeftRight endpoint b2)) => GetEndpoint (b1 :<|> b2) endpoint 'True where+ getEndpoint _ pM _ pEndpoint (_ :<|> lR) = getEndpoint pLeftRight pM (Proxy :: Proxy b2) pEndpoint lR+ where pLeftRight = Proxy :: Proxy (PickLeftRight endpoint b2)++-- Pathpiece+instance (KnownSymbol sym, GetEndpoint sa endpoint (PickLeftRight endpoint sa)) => GetEndpoint (sym :> sa) (sym :> endpoint) 'True where+ getEndpoint _ pM _ pEndpoint server = getEndpoint pLeftRight pM (Proxy :: Proxy sa) (Proxy :: Proxy endpoint) server+ where pLeftRight = Proxy :: Proxy (PickLeftRight endpoint sa)++-- Capture+instance (GetEndpoint sa endpoint (PickLeftRight endpoint sa)) => GetEndpoint (Capture sym a :> sa) (Capture sym1 a :> endpoint) 'True where+ getEndpoint _ pM _ pEndpoint server a = getEndpoint pLeftRight pM (Proxy :: Proxy sa) (Proxy :: Proxy endpoint) (server a)+ where pLeftRight = Proxy :: Proxy (PickLeftRight endpoint sa)++-- QueryParam+instance (GetEndpoint sa endpoint (PickLeftRight endpoint sa)) => GetEndpoint (QueryParam sym a :> sa) (QueryParam sym a :> endpoint) 'True where+ getEndpoint _ pM _ pEndpoint server ma = getEndpoint pLeftRight pM (Proxy :: Proxy sa) (Proxy :: Proxy endpoint) (server ma)+ where pLeftRight = Proxy :: Proxy (PickLeftRight endpoint sa)++-- QueryParams+instance (KnownSymbol sym, GetEndpoint sa endpoint (PickLeftRight endpoint sa)) => GetEndpoint (QueryParams sym a :> sa) (QueryParams sym a :> endpoint) 'True where+ getEndpoint _ pM _ pEndpoint server as = getEndpoint pLeftRight pM (Proxy :: Proxy sa) (Proxy :: Proxy endpoint) (server as)+ where pLeftRight = Proxy :: Proxy (PickLeftRight endpoint sa)++-- QueryFlag+instance (KnownSymbol sym, GetEndpoint sa endpoint (PickLeftRight endpoint sa)) => GetEndpoint (QueryFlag sym :> sa) (QueryFlag sym :> endpoint) 'True where+ getEndpoint _ pM _ pEndpoint server f = getEndpoint pLeftRight pM (Proxy :: Proxy sa) (Proxy :: Proxy endpoint) (server f)+ where pLeftRight = Proxy :: Proxy (PickLeftRight endpoint sa)+++-- Header+instance (KnownSymbol sym, GetEndpoint sa endpoint (PickLeftRight endpoint sa)) => GetEndpoint (Header sym a :> sa) (Header sym a :> endpoint) 'True where+ getEndpoint _ pM _ pEndpoint server ma = getEndpoint pLeftRight pM (Proxy :: Proxy sa) (Proxy :: Proxy endpoint) (server ma)+ where pLeftRight = Proxy :: Proxy (PickLeftRight endpoint sa)+++-- ReqBody+instance (GetEndpoint sa endpoint (PickLeftRight endpoint sa)) => GetEndpoint (ReqBody ct a :> sa) (ReqBody ct a :> endpoint) 'True where+ getEndpoint _ pM _ pEndpoint server a = getEndpoint pLeftRight pM (Proxy :: Proxy sa) (Proxy :: Proxy endpoint) (server a)+ where pLeftRight = Proxy :: Proxy (PickLeftRight endpoint sa)+++-- Verb+ -- (method :: k1) (statusCode :: Nat) (contentTypes :: [*])+instance GetEndpoint (Verb (n :: StdMethod) (s :: Nat) (ct :: [*]) a) (Verb (n :: StdMethod) (s :: Nat) (ct :: [*]) a) 'True where+ getEndpoint _ _ _ _ server = server
+ src/Servant/Subscriber.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE RankNTypes #-}+++module Servant.Subscriber (+ notify+, makeSubscriber+, serveSubscriber+) where++import Control.Concurrent.STM.TVar (TVar, readTVar, writeTVar, newTVar, modifyTVar')+import Data.Aeson+import GHC.Generics+import Data.Map (Map)+import qualified Data.Map as Map+import Debug.Trace (trace)+import Network.URI (URI(..), pathSegments)+import Data.Proxy+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time+import Network.WebSockets.Connection as WS+import Servant.Server+import Servant.Utils.Links (IsElem, HasLink, MkLink, safeLink)+import Control.Monad+import Servant.Subscriber.Subscribable+import Control.Monad.Trans.Maybe+import Control.Monad.IO.Class+import Control.Concurrent.STM+import Control.Monad.Trans.Class+import GHC.Conc+import Network.Wai+import Network.Wai.Handler.WebSockets+import Data.Monoid ((<>))++import Servant.Subscriber.Types+import qualified Servant.Subscriber.Client as Client+import Servant.Subscriber.Backend.Wai++makeSubscriber :: Path -> LogRunner -> STM (Subscriber api)+makeSubscriber entryPoint logRunner = do+ state <- newTVar Map.empty+ return $ Subscriber state entryPoint logRunner++serveSubscriber :: forall api. (HasServer api '[]) => Subscriber api -> Server api -> Application+serveSubscriber subscriber server req sendResponse = do+ let app = serve (Proxy :: Proxy api) server+ let opts = defaultConnectionOptions+ let runLog = runLogging subscriber+ let handleWSConnection pending = do+ connection <- acceptRequest pending+ forkPingThread connection 25+ runLog . Client.run app subscriber <=< atomically . Client.fromWebSocket $ connection+ if Path (pathInfo req) == entryPoint subscriber+ then websocketsOr opts handleWSConnection app req sendResponse+ else app req sendResponse
+ src/Servant/Subscriber/Backend.hs view
@@ -0,0 +1,34 @@+-- | A backend for subscriber allows us to query a server and get a response.+-- | We mimick Wai's interface but with 'Request' and 'Response' types that match our needs.+-- | Our only backend right now actually is implemented via the WAI Application interface, see: "Servant.Subscriber.Backend.Wai".+module Servant.Subscriber.Backend where++import qualified Blaze.ByteString.Builder as B+import Control.Concurrent.STM (STM, atomically, retry)+import Control.Concurrent.STM.TVar+import Control.Monad (void)+import Data.Aeson+import qualified Data.ByteString as BS+import qualified Data.CaseInsensitive as Case+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.Map (Map)+import Data.Text (Text)+import qualified Data.Text.Encoding as T+import Data.Time+import GHC.Generics+import qualified Network.HTTP.Types as H+import qualified Network.Wai as Wai+import qualified Network.Wai.Internal as Wai+import Network.WebSockets.Connection as WS+import Servant.Server++import Servant.Subscriber.Request+import Servant.Subscriber.Response++data ResponseReceived = ResponseReceived++type Application = HttpRequest -> (HttpResponse -> IO ResponseReceived) -> IO ResponseReceived++class Backend a where+ requestResource :: a -> Application
+ src/Servant/Subscriber/Backend/Wai.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+++-- | Backend of accessing a wai server:+module Servant.Subscriber.Backend.Wai where++import qualified Blaze.ByteString.Builder as B+import Control.Concurrent.STM (STM, atomically, retry)+import Control.Concurrent.STM.TVar+import Control.Monad (void)+import Data.Aeson+import qualified Data.ByteString as BS+import qualified Data.CaseInsensitive as Case+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.IORef+import Data.Map (Map)+import Data.Text (Text)+import qualified Data.Text.Encoding as T+import Data.Time+import GHC.Generics+import qualified Network.HTTP.Types as H+import qualified Network.Wai as Wai+import qualified Network.Wai.Internal as Wai+import Network.WebSockets.Connection as WS+import Servant.Server++import Servant.Subscriber.Backend+import Servant.Subscriber.Request as Req+import Servant.Subscriber.Response as Res+import Servant.Subscriber.Types++++instance Backend Wai.Application where+ requestResource app req sendResponse = do+ waiReq <- toWaiRequest req+ app waiReq (waiSendResponse sendResponse)+ return ResponseReceived++waiSendResponse :: (HttpResponse -> IO ResponseReceived) -> Wai.Response -> IO Wai.ResponseReceived+waiSendResponse sendResponse = fmap fixResponse . sendResponse . fromWaiResponse+ where fixResponse = const Wai.ResponseReceived++toWaiRequest :: HttpRequest -> IO Wai.Request+toWaiRequest r = do+ waiBody <- mkWaiRequestBody encodedBody+ return Wai.defaultRequest {+ Wai.requestMethod = T.encodeUtf8 . httpMethod $ r+ , Wai.pathInfo = toSegments . httpPath $ r+ , Wai.rawPathInfo = B.toByteString . H.encodePathSegments . toSegments . httpPath $ r+ , Wai.queryString = H.queryTextToQuery . httpQuery $ r+ , Wai.rawQueryString = B.toByteString . H.renderQueryText True . httpQuery $ r+ , Wai.requestHeaders = toHTTPHeaders . Req.httpHeaders $ r+ , Wai.requestBody = waiBody+ , Wai.requestBodyLength = Wai.KnownLength . fromIntegral . BS.length $ encodedBody+ }+ where+ encodedBody = B.toByteString . fromEncoding . toEncoding . Req.httpBody $ r++mkWaiRequestBody :: BS.ByteString -> IO (IO BS.ByteString)+mkWaiRequestBody b = do+ var <- newIORef b+ return $ do+ val <- readIORef var+ writeIORef var BS.empty+ return val+++fromWaiResponse :: Wai.Response -> HttpResponse+fromWaiResponse (Wai.ResponseBuilder status headers builder)= HttpResponse {+ httpStatus = fromHTTPStatus status+ , Res.httpHeaders = fromHTTPHeaders headers+ , Res.httpBody = ResponseBody builder+ }+fromWaiResponse _ = error "I am sorry - this 'Response' type is not yet implemented in servant-subscriber!"
+ src/Servant/Subscriber/Client.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+module Servant.Subscriber.Client where++import qualified Blaze.ByteString.Builder as B+import Control.Concurrent.Async+import Control.Concurrent.STM (STM, atomically, retry)+import Control.Concurrent.STM.TVar+import Control.Monad.Logger (MonadLogger, logDebug,+ logError, logInfo,+ monadLoggerLog)+import Control.Exception.Lifted (finally, try)+import Control.Exception (displayException, SomeException)+import Control.Monad.Trans.Control (MonadBaseControl)+import Data.Aeson+import Data.Bifunctor+import qualified Data.ByteString as BS+import qualified Data.CaseInsensitive as Case+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.Map (Map)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Time+import GHC.Generics+import qualified Network.HTTP.Types as H+import qualified Network.WebSockets as WS+import Network.WebSockets.Connection as WS+import Servant.Server++import Control.Monad+import Control.Monad.IO.Class+import Servant.Subscriber.Backend+import Servant.Subscriber.Request+import Servant.Subscriber.Response as Resp+import Servant.Subscriber.Subscribable+import Servant.Subscriber.Types as S++type ClientMonitors = Map Path StatusMonitor++data Client = Client {+ monitors :: !(TVar ClientMonitors)+ , readRequest :: !(IO (Maybe Request))+ , writeResponse :: !(Response -> IO ())+ }++data StatusMonitor = StatusMonitor {+ request :: !HttpRequest+, monitor :: !(TVar (RefCounted ResourceStatus))+, oldStatus :: !ResourceStatus+}++data Snapshot = Snapshot {+ snapshotCurrent :: ResourceStatus+, fullMonitor :: StatusMonitor+}++snapshotOld :: Snapshot -> ResourceStatus+snapshotOld = oldStatus . fullMonitor++toSnapshot :: StatusMonitor -> STM Snapshot+toSnapshot mon = do+ current <- readTVar $ monitor mon+ return Snapshot {+ snapshotCurrent = refValue current+ , fullMonitor = mon+ }++++snapshotRequest :: Snapshot -> HttpRequest+snapshotRequest = request . fullMonitor++fromWebSocket :: WS.Connection -> STM Client+fromWebSocket c = do+ ms <- newTVar Map.empty+ return Client {+ monitors = ms+ , readRequest = do+ msg <- WS.receiveDataMessage c+ case msg of+ WS.Text bs -> return $ decode bs+ WS.Binary _ -> error "Sorry - binary connections currently unsupported!"+ , writeResponse = sendDataMessage c . WS.Text . encode+ }++run :: (MonadLogger m, MonadBaseControl IO m, MonadIO m, Backend backend) => backend -> Subscriber api -> Client -> m ()+run b sub c = do+ let+ work = liftIO $ race_ (runMonitor b c) (handleRequests b sub c)+ cleanup = liftIO . atomically $ do+ ms <- readTVar (monitors c)+ mapM_ (unsubscribeMonitor sub) ms+ r <- try $ finally work cleanup+ case r of+ Left e -> $logDebug $ T.pack $ displayException (e :: SomeException)+ Right _ -> return ()++unsubscribeMonitor :: Subscriber api -> StatusMonitor -> STM ()+unsubscribeMonitor sub m =+ let+ path = httpPath . request $ m+ mon = monitor m+ in+ unsubscribe path mon sub++subscribeMonitor :: Subscriber api -> HttpRequest -> Client -> STM ()+subscribeMonitor sub req c = do+ let path = httpPath req+ tState <- subscribe path sub+ stateVal <- refValue <$> readTVar tState+ modifyTVar' (monitors c) $ Map.insert path (StatusMonitor req tState stateVal)++handleRequests :: Backend backend => backend -> Subscriber api -> Client -> IO ()+handleRequests b sub c = forever $ do+ req <- readRequest c+ case req of+ Nothing -> writeResponse c (RequestError ParseError)+ Just (Subscribe req) -> handleSubscribe b sub c req+ Just (Unsubscribe path) -> handleUnsubscribe b sub c path++handleSubscribe :: Backend backend => backend -> Subscriber api -> Client -> HttpRequest -> IO ()+handleSubscribe b sub c req = void $ requestResource b req $ \ httpResponse -> do+ let status = statusCode . httpStatus $ httpResponse+ let path = httpPath req+ let isGoodStatus = status >= 200 && status < 300 -- For now we only accept success+ if isGoodStatus+ then+ mapM_ (writeResponse c) <=< atomically $ do+ ms <- readTVar (monitors c)+ case Map.lookup path ms of+ Just _ -> return [RequestError (AlreadySubscribed path)]+ Nothing -> do+ subscribeMonitor sub req c+ return [Resp.Subscribed path, Resp.Modified path httpResponse]+ else+ writeResponse c $ RequestError (HttpRequestFailed req httpResponse)+ return ResponseReceived++handleUnsubscribe :: Backend backend => backend -> Subscriber api -> Client -> Path -> IO ()+handleUnsubscribe b sub c path = writeResponse c <=< atomically $ do+ ms <- readTVar (monitors c)+ case Map.lookup path ms of+ Nothing -> return $ RequestError (NoSuchSubscription path)+ Just m -> do+ unsubscribeMonitor sub m+ modifyTVar (monitors c) $ Map.delete path+ return $ Unsubscribed path++runMonitor :: Backend backend => backend -> Client -> IO ()+runMonitor b c = forever $ do+ changes <- atomically $ monitorChanges c+ mapM_ (sendUpdate b (writeResponse c)) changes++sendUpdate :: Backend backend => backend -> (Response -> IO ()) -> (HttpRequest, ResourceStatus) -> IO ()+sendUpdate b sendResponse (req, S.Deleted) = sendResponse $ Resp.Deleted (httpPath req)+sendUpdate b sendResponse (req, S.Modified _) = sendServerResponse b req sendResponse++sendServerResponse :: Backend backend => backend -> HttpRequest -> (Response -> IO ()) -> IO ()+sendServerResponse b req sendResponse = void $ requestResource b req+ $ \ httpResponse -> do+ let path = httpPath req+ sendResponse $ Resp.Modified path httpResponse+ return ResponseReceived++monitorChanges :: Client -> STM [(HttpRequest, ResourceStatus)]+monitorChanges c = do+ snapshots <- mapM toSnapshot . Map.elems =<< readTVar (monitors c)+ let result = getChanges snapshots+ if null result+ then retry+ else do+ let newMonitors = monitorsFromList . updateMonitors $ snapshots+ writeTVar (monitors c) newMonitors+ return result+++getChanges :: [Snapshot] -> [(HttpRequest, ResourceStatus)]+getChanges = map toChangeReport . filter monitorChanged++monitorChanged :: Snapshot -> Bool+monitorChanged m = snapshotCurrent m /= snapshotOld m++toChangeReport :: Snapshot -> (HttpRequest, ResourceStatus)+toChangeReport m = (snapshotRequest m, snapshotCurrent m)++updateMonitors :: [Snapshot] -> [StatusMonitor]+updateMonitors = map updateOldStatus . filter ((/= S.Deleted) . snapshotCurrent)++updateOldStatus :: Snapshot -> StatusMonitor+updateOldStatus m = (fullMonitor m) {+ oldStatus = snapshotCurrent m+ }++monitorsFromList :: [StatusMonitor] -> ClientMonitors+monitorsFromList ms = let+ paths = map (httpPath . request) ms+ assList = zip paths ms+ in+ Map.fromList assList
+ src/Servant/Subscriber/Request.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Servant.Subscriber.Request where++import qualified Blaze.ByteString.Builder as B+import Control.Concurrent.STM.TVar (TVar)+import Data.Aeson+-- import Data.Aeson.Encode.Builder as AesonBuilder+import qualified Data.ByteString as BS+import qualified Data.CaseInsensitive as Case+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.Map (Map)+import Data.Text (Text)+import qualified Data.Text.Encoding as T+import Data.Time+import GHC.Generics+import qualified Network.HTTP.Types as H+import qualified Network.Wai as Wai+import Network.WebSockets.Connection as WS+import Servant.Server++import Data.Bifunctor+import Servant.Subscriber.Subscribable+import Servant.Subscriber.Types+++++{--| We don't use Network.HTTP.Types here, because we need FromJSON instances, which can not+ be derived for 'ByteString'+--}+type RequestHeader = (Text, Text)+type RequestHeaders = [RequestHeader]++-- | Any message from the client is a 'Request':+-- Currently you can only subscribe to 'GET' method endpoints.+data Request =+ Subscribe !HttpRequest+ | Unsubscribe !Path+ deriving Generic++instance FromJSON Request+instance ToJSON Request+++data HttpRequest = HttpRequest {+ httpMethod :: !Text+, httpPath :: !Path+, httpHeaders :: RequestHeaders+, httpQuery :: H.QueryText+, httpBody :: RequestBody+} deriving Generic++instance FromJSON HttpRequest+instance ToJSON HttpRequest++newtype RequestBody = RequestBody Text deriving (Generic, ToJSON, FromJSON)++toHTTPHeader :: RequestHeader -> H.Header+toHTTPHeader = bimap (Case.mk . T.encodeUtf8) T.encodeUtf8++toHTTPHeaders :: RequestHeaders -> H.RequestHeaders+toHTTPHeaders = map toHTTPHeader++requestPath :: Request -> Path+requestPath (Subscribe req) = httpPath req+requestPath (Unsubscribe path) = path
+ src/Servant/Subscriber/Response.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE DeriveGeneric #-}+module Servant.Subscriber.Response where+++import qualified Blaze.ByteString.Builder as B+import qualified Blaze.ByteString.Builder.Char8 as B+import Control.Concurrent.STM (STM, atomically, retry)+import Control.Concurrent.STM.TVar+import Control.Monad (void)+import Data.Aeson+import Data.Aeson.Parser (value)+import Data.Aeson.Types (unsafeToEncoding)+import qualified Data.ByteString as BS+import qualified Data.CaseInsensitive as Case+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.Map (Map)+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Time+import GHC.Generics+import qualified Network.HTTP.Types as H+import qualified Network.Wai as Wai+import qualified Network.Wai.Internal as Wai+import Network.WebSockets.Connection as WS+import Servant.Server++import Data.Attoparsec.ByteString (parseOnly)+import Data.Bifunctor++import qualified Servant.Subscriber.Request as R+import Servant.Subscriber.Subscribable+import Servant.Subscriber.Types+++type ResponseHeader = R.RequestHeader+type ResponseHeaders = R.RequestHeaders++-- | Any message from the server is a Response.+data Response =+ Subscribed !Path -- |< Resource was successfully subscribed+ | Modified !Path !HttpResponse -- |< Can also be a non 2xx code, ServerError only triggers on the very first response, resulting in a failed subscription.+ | Deleted !Path+ | Unsubscribed !Path+ | RequestError !RequestError+ deriving Generic++instance ToJSON Response++data HttpResponse = HttpResponse {+ httpStatus :: !Status+, httpHeaders :: !ResponseHeaders+, httpBody :: ResponseBody+} deriving (Generic)++instance ToJSON HttpResponse++data Status = Status {+ statusCode :: !Int+, statusMessage :: !Text+} deriving Generic++instance ToJSON Status++-- | Your subscription did not work out because:+data RequestError =+ ParseError+ | HttpRequestFailed !R.HttpRequest !HttpResponse -- |< The server replied with some none 2xx status code. Thus your subscription failed.+ | NoSuchSubscription !Path+ | AlreadySubscribed !Path deriving Generic++instance ToJSON RequestError+++data ResponseBody = ResponseBody B.Builder deriving Generic++instance ToJSON ResponseBody where+ toJSON (ResponseBody b) = getValue $ parseOnly value (B.toByteString (wrapInString b))+ where+ getValue r = case r of+ Left e -> error e+ Right r -> r+ toEncoding (ResponseBody b) = unsafeToEncoding . wrapInString $ b++fromHTTPHeader :: H.Header -> ResponseHeader+fromHTTPHeader = bimap (T.decodeUtf8 . Case.original) T.decodeUtf8++fromHTTPHeaders :: H.ResponseHeaders -> ResponseHeaders+fromHTTPHeaders = map fromHTTPHeader++fromHTTPStatus :: H.Status -> Status+fromHTTPStatus s = Status {+ statusCode = H.statusCode s+, statusMessage = T.decodeUtf8 . H.statusMessage $ s+}++fromServantError :: ServantErr -> HttpResponse+fromServantError err = HttpResponse {+ httpStatus = Status (errHTTPCode err) (T.pack $ errReasonPhrase err)+, httpHeaders = fromHTTPHeaders . errHeaders $ err+, httpBody = ResponseBody . B.fromLazyByteString . errBody $ err+}++wrapInString :: B.Builder -> B.Builder+wrapInString x = B.fromChar '"' <> x <> B.fromChar '"'
+ src/Servant/Subscriber/Subscribable.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++++module Servant.Subscriber.Subscribable where++import Control.Lens+import Data.Aeson (FromJSON, ToJSON)+import Data.Proxy+import GHC.Exts (Constraint)+import GHC.Generics+import GHC.TypeLits+import Servant+import Servant.Foreign+import Servant.Foreign.Internal (_FunctionName)+import Servant.Utils.Links+++data Subscribable+++-- | You may use this type family to tell the type checker that your custom+-- type may be skipped as part of a link. This is useful for things like+-- 'QueryParam' that are optional in a URI and are not part of a subscription uri.+--+-- >>> data CustomThing+-- >>> type instance IsSubscribable' e (CustomThing :> sa) s = IsSubscribable e sa s+--+-- Note that 'IsSubscribable' is called, which will mutually recurse back to `IsSubscribable'`+-- if it exhausts all other options again.+--+-- Once you have written a HasSubscription instance for CustomThing you are ready to+-- go.+type family IsSubscribable' endpoint api :: Constraint+++type family IsSubscribable endpoint api :: Constraint where+ IsSubscribable sa (Subscribable :> sb) = ()+ IsSubscribable e (sa :<|> sb) = Or (IsSubscribable e sa) (IsSubscribable e sb)+ IsSubscribable ((sym :: Symbol) :> sa) (sym :> sb) = IsSubscribable sa sb+ IsSubscribable (e :> sa) (e :> sb) = IsSubscribable sa sb+ IsSubscribable sa (Header sym x :> sb) = IsSubscribable sa sb+ IsSubscribable sa (ReqBody y x :> sb) = IsSubscribable sa sb+ IsSubscribable (Capture z y :> sa) (Capture x y :> sb)+ = IsSubscribable sa sb+ IsSubscribable sa (QueryParam x y :> sb) = IsSubscribable sa sb+ IsSubscribable sa (QueryParams x y :> sb)= IsSubscribable sa sb+ IsSubscribable sa (QueryFlag x :> sb) = IsSubscribable sa sb+ IsSubscribable e a = IsSubscribable' e a++type instance IsElem' e (Subscribable :> s) = IsElem e s++-- | A valid endpoint may only contain Symbols and captures:+type family IsValidEndpoint endpoint :: Constraint where+ IsValidEndpoint ((sym :: Symbol) :> sub) = IsValidEndpoint sub+ IsValidEndpoint (Capture z y :> sub) = IsValidEndpoint sub+ IsValidEndpoint (Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [*]) (a :: *)) = ()++instance HasServer sublayout context => HasServer (Subscribable :> sublayout) context where+ type ServerT (Subscribable :> sublayout) m = ServerT sublayout m+ route _ = route (Proxy :: Proxy sublayout)+++instance HasForeign lang ftype sublayout => HasForeign lang ftype (Subscribable :> sublayout) where+ type Foreign ftype (Subscribable :> sublayout) = Foreign ftype sublayout+ -- foreignFor :: Proxy lang -> Proxy ftype -> Proxy layout -> Req ftype -> Foreign ftype layout+ foreignFor lang ftype _ req = foreignFor lang ftype (Proxy :: Proxy sublayout) $+ req & reqFuncName . _FunctionName %~ ("" :) -- Prepend empty string for marking as subscribable.++-------------- Copied from Servant.Util.Links (they are not exported) ----------++-- | If both a or b produce an empty constraint, produce an empty constraint.+type family And (a :: Constraint) (b :: Constraint) :: Constraint where+ And () () = ()++type family Elem e es :: Constraint where+ Elem x (x ': xs) = ()+ Elem y (x ': xs) = Elem y xs++--------------------------------------------------------------------------------
+ src/Servant/Subscriber/Types.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+++module Servant.Subscriber.Types where++import Control.Concurrent.STM+import Control.Concurrent.STM.TVar (TVar, modifyTVar', newTVar,+ readTVar, writeTVar)+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe+import Data.Aeson+import Data.Aeson.Types+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Proxy+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time+import GHC.Conc+import GHC.Generics+import Network.URI (URI (..), pathSegments)+import Servant.Utils.Links (IsElem, HasLink, MkLink, safeLink)+import Data.String (IsString, fromString)+import System.FilePath.Posix (splitPath)++import Servant.Subscriber.Subscribable++newtype Path = Path [Text] deriving (Eq, Generic, Ord, Show, ToJSON, FromJSON)++instance IsString Path where+ fromString = Path . map T.pack . splitPath++type ReferenceCount = Int+type Revision = Int+type ResourceStatusMap = Map Path (TVar (RefCounted ResourceStatus))++data ResourceStatus =+ Modified Revision -- |< Watching for 'Modified' implies watching for 'Deleted'+ | Deleted+ deriving (Eq, Show)++data RefCounted a = RefCounted {+ refCount :: ReferenceCount+, refValue :: a+}++instance Functor RefCounted where+ fmap f (RefCounted c v) = RefCounted c (f v)++type LogRunner = forall m a. MonadIO m => LoggingT m a -> m a++data Subscriber api = Subscriber {+ {--+ In order to improve multithread performance even more, this Map could be replaced with some hierarchical Map data structure:++ > type TreeMap = Either (TVar (Map PathPiece MapElem)) ResourceStatus+ > Map PathPiece TreeMap+ with PathPiece being a part of the URI path:++ > 'families/1200/invitations'++ here families, 1200 and invitations. This way Map updates are more local and not every change to some element in the tree+ needs to update the same toplevel Map TVar. This could improve scalability, if multi processor performance is not good enough.+ --}+ subState :: !(TVar ResourceStatusMap)+-- On which path do we wait for WebSocket connections?+, entryPoint :: !Path+, runLogging :: LogRunner+}++data Event = DeleteEvent | ModifyEvent deriving (Eq)++{--|+ Notify the subscriber about a changed resource.+ You have to provide a typesafe link to the changed resource. Only+ Symbols and Captures are allowed in this link.++ You need to provide a proxy to the API too. This is needed to check that the endpoint is valid+ and points to a 'Subscribable' resource.++ One piece is still missing - we have to fill out captures, that's what the getLink parameter is+ for: You will typicall provide a lamda there providing needed parameters.++ TODO: Example!+--}+notify :: forall api endpoint. (IsElem endpoint api, HasLink endpoint+ , IsValidEndpoint endpoint, IsSubscribable endpoint api)+ => Subscriber api+ -> Event+ -> Proxy endpoint+ -> (MkLink endpoint -> URI)+ -> STM ()+notify subscriber event pEndpoint getLink = do+ let mkPath = Path . map T.pack . pathSegments . getLink+ let resource = mkPath $ safeLink (Proxy :: Proxy api) pEndpoint+ modifyState event resource subscriber++-- | Version of notify that lives in 'IO' - for your convenience.+notifyIO :: forall api endpoint. (IsElem endpoint api, HasLink endpoint+ , IsValidEndpoint endpoint, IsSubscribable endpoint api)+ => Subscriber api+ -> Event+ -> Proxy endpoint+ -> (MkLink endpoint -> URI)+ -> IO ()+notifyIO subscriber event pEndpoint getLink = atomically $ notify subscriber event pEndpoint getLink+++-- | Subscribe to a ResourceStatus - it will be created when not present+subscribe :: Path -> Subscriber api -> STM (TVar (RefCounted ResourceStatus))+subscribe p s = do+ states <- readTVar $ subState s+ let mState = Map.lookup p states+ case mState of+ Nothing -> do+ state <- newTVar $ RefCounted 1 (Modified 0)+ writeTVar (subState s) $ Map.insert p state states+ return state+ Just state -> do+ modifyTVar' state $ \s -> s { refCount = refCount s + 1}+ return state++-- | Unget a previously got ResourceState - make sure you match every call to subscribe with a call to unsubscribe!+unsubscribe :: Path -> TVar (RefCounted ResourceStatus) -> Subscriber api -> STM ()+unsubscribe p tv s = do+ v <- (\a -> a { refCount = refCount a - 1}) <$> readTVar tv+ if refCount v == 0+ then modifyTVar' (subState s) (Map.delete p)+ else writeTVar tv v++-- | Modify a ResourceState if it is present in the map, otherwise do nothing.+modifyState :: Event -> Path -> Subscriber api -> STM ()+modifyState event p s = do+ rMap <- readTVar (subState s)+ case Map.lookup p rMap of+ Nothing -> return ()+ Just refStatus -> do+ modifyTVar refStatus $ fmap (eventHandler event)+ when (event == DeleteEvent) $ modifyTVar (subState s) (Map.delete p)++eventHandler :: Event -> ResourceStatus -> ResourceStatus+eventHandler ModifyEvent = doModify+eventHandler DeleteEvent = doDelete++doDelete :: ResourceStatus -> ResourceStatus+doDelete (Modified _) = Deleted+doDelete _ = error "Resource can not be deleted - it does not exist!"++doModify :: ResourceStatus -> ResourceStatus+doModify (Modified n) = Modified (n + 1)+doModify _ = error "Resource can not be modified - it does not exist!"++toSegments :: Path -> [Text]+toSegments (Path xs) = xs
+ test/Spec.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+-- {-# LANGUAGE NoMonomorphismRestriction #-}+++import Control.Monad.Except+import Data.Aeson.Compat+import Data.Aeson.Types+import Data.Attoparsec.ByteString+import Data.ByteString (ByteString)+import Data.List+import Data.Maybe+import Data.String.Conversions+import Data.Time.Calendar+import GHC.Generics+import Lucid+import Network.HTTP.Media ((//), (/:))+import Network.Wai+import Network.Wai.Handler.Warp+import Servant+import System.Directory+import Text.Blaze+import Text.Blaze.Html.Renderer.Utf8+import qualified Data.Aeson.Parser+import qualified Text.Blaze.Html++ +import Lib+++type API = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position+ :<|> "hello" :> QueryParam "name" String :> Get '[JSON] HelloMessage+ :<|> "marketing" :> ReqBody '[JSON] ClientInfo :> Post '[JSON] Email++data Position = Position+ { xCoord :: Int+ , yCoord :: Int+ } deriving (Generic, Show)++instance ToJSON Position++newtype HelloMessage = HelloMessage { msg :: String }+ deriving (Generic, Show)++instance ToJSON HelloMessage++data ClientInfo = ClientInfo+ { clientName :: String+ , clientEmail :: String+ , clientAge :: Int+ , clientInterestedIn :: [String]+ } deriving Generic++instance FromJSON ClientInfo+instance ToJSON ClientInfo++data Email = Email+ { from :: String+ , to :: String+ , subject :: String+ , body :: String+ } deriving Generic++instance ToJSON Email++emailForClient :: ClientInfo -> Email+emailForClient c = Email from' to' subject' body'++ where from' = "great@company.com"+ to' = clientEmail c+ subject' = "Hey " ++ clientName c ++ ", we miss you!"+ body' = "Hi " ++ clientName c ++ ",\n\n"+ ++ "Since you've recently turned " ++ show (clientAge c)+ ++ ", have you checked out our latest "+ ++ intercalate ", " (clientInterestedIn c)+ ++ " products? Give us a visit!"++server3 :: ServerT API (ExceptT ServantErr IO)+server3 = position+ :<|> hello+ :<|> marketing++ where position :: Int -> Int -> ExceptT ServantErr IO Position+ position x y = return (Position x y)++ hello :: Maybe String -> ExceptT ServantErr IO HelloMessage+ hello mname = return . HelloMessage $ case mname of+ Nothing -> "Hello, anonymous coward"+ Just n -> "Hello, " ++ n++ marketing :: ClientInfo -> ExceptT ServantErr IO Email+ marketing clientinfo = return (emailForClient clientinfo)++userAPI :: Proxy API+userAPI = Proxy++app3 :: Application+app3 = serve userAPI server3+++callServer3 :: forall endpoint. (GetEndpoint API endpoint (PickLeftRight endpoint API))+ => Proxy endpoint+ -> ServerT endpoint (ExceptT ServantErr IO)+callServer3 pE = callHandler (Proxy :: Proxy API) server3 pE++main :: IO ()+main = do+ -- Let's call handler by url!+ let endpoint :: Proxy ("position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position)+ endpoint = Proxy+ pos <- runExceptT $ callServer3 endpoint 9 2+ print pos+ let endpoint2 :: Proxy ("hello" :> QueryParam "name" String :> Get '[JSON] HelloMessage)+ endpoint2 = Proxy+ hello <- runExceptT $ callServer3 endpoint2 $ Just "Robert"+ hello2 <- runExceptT $ callServer3 endpoint2 Nothing+ print hello+ print hello2