servant-zeppelin-client (empty) → 0.1.0.0
raw patch · 7 files changed
+491/−0 lines, 7 filesdep +QuickCheckdep +aesondep +basesetup-changed
Dependencies added: QuickCheck, aeson, base, data-default-class, hspec, http-client, mtl, servant, servant-client, servant-server, servant-zeppelin, servant-zeppelin-client, servant-zeppelin-server, singletons, string-conversions, text, wai-extra, warp
Files
- LICENSE +30/−0
- README.md +1/−0
- Setup.hs +2/−0
- servant-zeppelin-client.cabal +71/−0
- src/Servant/Zeppelin/Client.hs +151/−0
- test/Servant/Zeppelin/ClientSpec.hs +234/−0
- test/Spec.hs +2/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2017++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 Author name here 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,1 @@+# servant-side-loaded
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ servant-zeppelin-client.cabal view
@@ -0,0 +1,71 @@+name: servant-zeppelin-client+version: 0.1.0.0+homepage: https://github.com/martyall/servant-zeppelin#readme+license: BSD3+license-file: LICENSE+author: Martin Allen, Ben Weitzman+maintainer: martin[dot]allen26[at]gmail.com+synopsis: Client library for servant-zeppelin combinators.+copyright: 2017 Martin Allen, Ben Weitzman+category: Web+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Servant.Zeppelin.Client+ build-depends: base >= 4.7 && < 5+ , aeson+ , singletons+ , servant+ , servant-client >= 0.10+ , servant-zeppelin+ , text+ default-language: Haskell2010+ default-extensions: GADTs+ , KindSignatures+ , FlexibleInstances+ , FlexibleContexts+ , OverloadedStrings+ , PolyKinds+ , RankNTypes+ , DataKinds+ , TypeOperators+ , TypeFamilies+ , TypeApplications+ , TypeInType+ , MultiParamTypeClasses+ , ScopedTypeVariables+ , ConstraintKinds+ + ghc-options: -Wall++test-suite servant-zeppelin-cient-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: base+ , aeson+ , data-default-class+ , hspec+ , http-client+ , mtl+ , QuickCheck+ , servant+ , servant-server+ , servant-client+ , servant-zeppelin+ , servant-zeppelin-server+ , servant-zeppelin-client+ , singletons+ , string-conversions+ , warp+ , wai-extra+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010+ other-modules: Servant.Zeppelin.ClientSpec++source-repository head+ type: git+ location: https://github.com/martyall/servant-zeppelin
+ src/Servant/Zeppelin/Client.hs view
@@ -0,0 +1,151 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE UndecidableInstances #-}++module Servant.Zeppelin.Client+ ( projectDependency+ , DepClient(..)+ -- * Re-exports+ , SideLoaded(..)+ , SideLoad+ , SBool+ ) where++import Data.Aeson+import Data.Functor.Identity+import Data.Kind+import Data.Proxy+import Data.Singletons.Prelude hiding ((:>))+import Data.Singletons.TypeLits+import qualified Data.Text as T+import Servant.API+import Servant.Client+import Servant.Common.Req++import Servant.Zeppelin+import Servant.Zeppelin.Internal.Types++--------------------------------------------------------------------------------+-- FromJSON Instances+--------------------------------------------------------------------------------++instance FromJSON (DependencyList Identity '[] '[]) where+ parseJSON (Object _) = return NilDeps+ -- this can't actually happen.+ parseJSON _ = fail "Nil dependency list should be the empty object."++instance ( FromJSON (DependencyList Identity ds ds)+ , KnownSymbol (NamedDependency d)+ , FromJSON d+ ) => FromJSON (DependencyList Identity (d : ds) (d : ds)) where+ parseJSON o@(Object v) = do+ d <- v .: (T.pack . symbolVal $ Proxy @(NamedDependency d))+ ds <- parseJSON o+ return $ d :&: ds+ parseJSON _ = fail "Failed to parse a dependency."++instance ( FromJSON (DependencyList Identity ds ds)+ , FromJSON a+ ) => FromJSON (SideLoaded a ds) where+ parseJSON (Object v') = do+ a <- v' .: "data"+ ds <- v' .: "dependencies"+ return $ SideLoaded a ds+ parseJSON _ = fail "Could not parse dependencies."++--------------------------------------------------------------------------------+-- HList Accessors+--------------------------------------------------------------------------------++-- | 'ProjectDependency' @bs b' allows you to project to a dependency type from+-- a 'DependencyList'. If 'b' in 'bs', type inference is used to project to 'b'.+-- For example:+--+-- > let (SideLoaded a deps) = s :: SideLoaded Album '[Person, [Photo]]+-- > personId . projectDependency $ deps :: PersonId+class ProjectDependency bs b where+ projectDependency :: forall fs m . DependencyList m bs fs -> b++instance {-# OVERLAPPING #-} ProjectDependency (b : bs) b where+ projectDependency (b :&: _) = b++instance {-# OVERLAPPABLE #-} ProjectDependency bs b => ProjectDependency (a : bs) b where+ projectDependency (_ :&: bs ) = projectDependency bs++--------------------------------------------------------------------------------+-- Dependent Client+--------------------------------------------------------------------------------++-- | 'DependentClient' is a wrapper around a dependently typed function that when+-- given a singleton 'STrue' has return type 'SideLoaded' @a deps@, and+-- when given 'SFalse' has return type @a@. For example:+--+-- > data Person =+-- > Person { personId :: PersonId+-- > , personName :: String+-- > } deriving (Eq, Show, Generic)+-- >+-- > instance FromJSON Person+-- >+-- > data Photo =+-- > Photo { photoId :: PhotoId+-- > , photoCaption :: String+-- > , artistId :: PersonId+-- > } deriving (Eq, Show, Generic)+-- >+-- > instance FromJSON Photo+-- >+-- > data Album =+-- > Album { albumId :: AlbumId+-- > , albumName :: String+-- > , albumOwner :: PersonId+-- > , albumPhotos :: [PhotoId]+-- > } deriving (Eq, Show, Generic)+-- >+-- > instance FromJSON Album+-- >+-- > type API = "albums" :> Capture "albumId" AlbumId+-- > :> Get '[JSON, PlainText] Album+-- > :> SideLoad '[Person, [Photo]]+-- >+-- > type AlbumDeps = '[Person, [Photo]]+-- >+-- > getAlbumClientFull :: Manager+-- > -> BaseUrl+-- > -> AlbumId+-- > -> IO (Either ServantError (SideLoaded Album AlbumDeps))+-- > getAlbumClientFull m burl aid =+-- > flip runClientM (ClientEnv m burl) $+-- > runDepClient (client api aid) STrue+-- >+-- > getAlbumClient :: Manager+-- > -> BaseUrl+-- > -> AlbumId+-- > -> IO (Either ServantError Album)+-- > getAlbumClient m burl aid =+-- > flip runClientM (ClientEnv m burl) $+-- > runDepClient (client api aid) SFalse++newtype DepClient (ix :: Bool -> *) (f :: Bool ~> Type) =+ DepClient {runDepClient :: forall (b :: Bool) . ix b -> Client (Apply f b)}++data SideLoadTerminal :: method -> status -> cts -> a -> deps -> (Bool ~> Type) where+ SideLoadTerminal :: SideLoadTerminal method status cts a deps b++type instance Apply (SideLoadTerminal method status cts a deps) b =+ If b (Verb method status cts (SideLoaded a deps)) (Verb method status cts a)++instance {-# OVERLAPPABLE #-}+ ( MimeUnrender JSON a+ , MimeUnrender JSON (SideLoaded a deps)+ , ReflectMethod method+ ) => HasClient (Verb method status cts a :> SideLoad deps) where++ type Client (Verb method status cts a :> SideLoad deps) = DepClient SBool (SideLoadTerminal method status cts a deps)+ clientWithRoute Proxy req = DepClient $ \sb ->+ case sb of+ STrue -> let req' = appendToQueryString "sideload" (Just "true") req+ in snd <$> performRequestCT (Proxy @JSON) method req'+ SFalse -> snd <$> performRequestCT (Proxy @JSON) method req+ where method = reflectMethod (Proxy @method)
+ test/Servant/Zeppelin/ClientSpec.hs view
@@ -0,0 +1,234 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{-# OPTIONS_GHC -fno-warn-unused-binds#-}++module Servant.Zeppelin.ClientSpec (spec) where++import Control.Monad.Except+import Data.Aeson+import Data.Either+import qualified Data.List as L+import Data.Singletons.Prelude hiding ((:>))+import Data.String.Conversions+import GHC.Generics+import Servant.Server+import Servant.Zeppelin+import Servant.Zeppelin.Client+import Servant.Zeppelin.Server++import Network.Wai.Handler.Warp (testWithApplication)+import System.IO.Unsafe (unsafePerformIO)+++import Network.HTTP.Client (Manager, defaultManagerSettings,+ newManager)+import Servant+import Servant.Client+import Test.Hspec+import Test.QuickCheck+++spec :: Spec+spec = do+ hasClientSpec+ return ()++hasClientSpec :: Spec+hasClientSpec = describe "HasClient" $ around (testWithApplication $ return app) $ do++ it "succeeds when we ask for the inflated data" $ \port -> quickCheckWith qcArgs $ property+ $ \aid -> do+ ealbum <- getAlbumClientFull mgr (BaseUrl Http "localhost" port "") aid+ let Just (album, person, photos) = do+ a <- getAlbumById aid+ p <- getPersonById (albumOwner a)+ let phs = getPhotosByIds (albumPhotos a)+ return (a, p, phs)+ ealbum `shouldSatisfy` isRight+ let Right (SideLoaded a deps) = ealbum+ person `shouldBe` projectDependency deps+ photos `shouldBe` projectDependency deps+ a `shouldBe` album++ it "succeeds when we ask for the uninflated data" $ \port -> quickCheckWith qcArgs $ property+ $ \aid -> do+ ealbum <- getAlbumClient mgr (BaseUrl Http "localhost" port "") aid+ ealbum `shouldSatisfy` isRight+ let Right album = ealbum+ Just album' = getAlbumById aid+ album `shouldBe` album'++qcArgs :: Args+qcArgs = stdArgs {maxSuccess = 20}++--------------------------------------------------------------------------------+-- | Client+--------------------------------------------------------------------------------++mgr :: Manager+mgr = unsafePerformIO $ newManager defaultManagerSettings+{-# NOINLINE mgr #-}++type AlbumDeps = '[Person, [Photo]]++getAlbumClientFull :: Manager+ -> BaseUrl+ -> AlbumId+ -> IO (Either ServantError (SideLoaded Album AlbumDeps))+getAlbumClientFull m burl aid =+ flip runClientM (ClientEnv m burl) $+ runDepClient (client api aid) STrue++getAlbumClient :: Manager+ -> BaseUrl+ -> AlbumId+ -> IO (Either ServantError Album)+getAlbumClient m burl aid =+ flip runClientM (ClientEnv m burl) $+ runDepClient (client api aid) SFalse++--------------------------------------------------------------------------------+-- | Application+--------------------------------------------------------------------------------++type API = "albums" :> Capture "albumId" AlbumId+ :> Get '[JSON, PlainText] Album+ :> SideLoad '[Person, [Photo]]++api :: Proxy API+api = Proxy @API++newtype QueryError = LookupError String++newtype DB a = DB { runDB :: ExceptT QueryError IO a }+ deriving (Functor, Applicative, Monad, MonadIO, MonadError QueryError)++server :: ServerT API Handler+server = albumHandler++albumHandler :: AlbumId -> Handler Album+albumHandler aid =+ case L.find (\album -> albumId album == aid) albumTable of+ Nothing -> throwError err404+ Just album -> return album++phi :: DB :~> Handler+phi = NT $ \ha -> do+ ea <- liftIO . runExceptT . runDB $ ha+ case ea of+ Left (LookupError msg) -> throwError err404 {errBody = cs msg}+ Right a -> return a++app :: Application+app = serveWithContext api ctxt server+ where+ ctxt :: Context '[DB :~> Handler]+ ctxt = phi :. EmptyContext++--------------------------------------------------------------------------------+-- | Data+--------------------------------------------------------------------------------+-- | Photo++newtype PhotoId = PhotoId Int+ deriving (Eq, Show, Num, Generic, ToJSON, FromJSON)++type instance NamedDependency [Photo] = "photos"+type instance NamedDependency [PhotoId] = "photoIds"++data Photo =+ Photo { photoId :: PhotoId+ , photoCaption :: String+ , artistId :: PersonId+ } deriving (Eq, Show, Generic)++instance ToJSON Photo+instance FromJSON Photo++photosTable :: [Photo]+photosTable = [ Photo 1 "At the Beach." 1+ , Photo 2 "At the Mountain." 1+ , Photo 3 "With Friends." 1+ , Photo 4 "Bow Wow." 2+ ]++getPhotosByIds :: [PhotoId] -> [Photo]+getPhotosByIds pids = filter (\photo -> photoId photo `elem` pids) photosTable++instance Inflatable DB [PhotoId] where+ type Full DB [PhotoId] = [Photo]+ inflator = return . getPhotosByIds++-- | Person++newtype PersonId = PersonId Int+ deriving (Eq, Show, Num, Generic, ToJSON, FromJSON)++type instance NamedDependency Person = "person"++data Person =+ Person { personId :: PersonId+ , personName :: String+ } deriving (Eq, Show, Generic)++instance ToJSON Person+instance FromJSON Person++personTable :: [Person]+personTable = [ Person 1 "Alice"+ , Person 2 "Fido"+ ]++getPersonById :: PersonId -> Maybe Person+getPersonById pid = L.find (\person -> personId person == pid) personTable++instance Inflatable DB PersonId where+ type Full DB PersonId = Person+ inflator pid =+ case getPersonById pid of+ Nothing -> throwError . LookupError $ "Could not find person with id: " <> show pid+ Just person -> return person++-- | Albums++newtype AlbumId = AlbumId Int+ deriving (Eq, Show, Num, ToJSON, FromJSON, FromHttpApiData, ToHttpApiData)++instance Arbitrary AlbumId where+ arbitrary = elements $ map AlbumId [1..3]++data Album =+ Album { albumId :: AlbumId+ , albumName :: String+ , albumOwner :: PersonId+ , albumPhotos :: [PhotoId]+ } deriving (Eq, Show, Generic)++instance ToJSON Album+instance FromJSON Album++albumTable :: [Album]+albumTable = [ Album 1 "Vacations" 1 [1,2]+ , Album 2 "In the City" 1 [3]+ , Album 3 "Howl" 2 [4]+ ]++getAlbumById :: AlbumId -> Maybe Album+getAlbumById aid = L.find (\album -> albumId album == aid) albumTable++instance HasDependencies DB Album '[PersonId, [PhotoId]] where+ getDependencies (Album _ _ owner pIds) = owner :&: pIds :&: NilDeps++instance MimeRender PlainText Album where+ mimeRender _ _ = "Album"
+ test/Spec.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+