diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2017 MATSUBARA Nobutada + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/rakuten.cabal b/rakuten.cabal new file mode 100644 --- /dev/null +++ b/rakuten.cabal @@ -0,0 +1,98 @@ +-- This file has been generated from package.yaml by hpack version 0.17.1. +-- +-- see: https://github.com/sol/hpack + +name: rakuten +version: 0.1.0.0 +synopsis: The Rakuten API in Haskell +description: See README at +homepage: https://github.com/matsubara0507/rakuten#readme +bug-reports: https://github.com/matsubara0507/rakuten/issues +license: MIT +license-file: LICENSE +author: MATSUBARA Nobutada +maintainer: MATSUBARA Nobutada +copyright: 2017 MATSUBARA Nobutada +category: Web +build-type: Simple +cabal-version: >= 1.10 + +source-repository head + type: git + location: https://github.com/matsubara0507/rakuten + +library + hs-source-dirs: + src + ghc-options: -Wall + exposed-modules: + Rakuten + Rakuten.Client + Rakuten.Endpoints + Rakuten.Endpoints.Ichiba + Rakuten.Types + Rakuten.Types.Base + Rakuten.Types.Class + Rakuten.Types.Error + Rakuten.Types.Ichiba + other-modules: + Paths_rakuten + build-depends: + base >=4.7 && <5 + , aeson >=1.0.2.1 && <1.3 + , bytestring >=0.10.8.1 && <0.11 + , connection >=0.2.7 && <0.3 + , constraints >=0.9.1 && <0.10 + , data-default-class >=0.1.2.0 && <0.2 + , extensible >=0.4.1 && <0.5 + , http-api-data >=0.3.5 && <0.3.8 + , http-client >=0.5.5.0 && <0.6 + , http-client-tls >=0.3.3.1 && <0.4 + , http-types >=0.9.1 && <0.10 + , lens >=4.15.3 && <5.0 + , req >=0.3.0 && <0.5 + , text >=1.2.2.1 && <1.3 + , unordered-containers >=0.2.8 && <0.3 + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + src + ghc-options: -Wall + build-depends: + base >=4.7 && <5 + , aeson >=1.0.2.1 && <1.3 + , bytestring >=0.10.8.1 && <0.11 + , connection >=0.2.7 && <0.3 + , constraints >=0.9.1 && <0.10 + , data-default-class >=0.1.2.0 && <0.2 + , extensible >=0.4.1 && <0.5 + , http-api-data >=0.3.5 && <0.3.8 + , http-client >=0.5.5.0 && <0.6 + , http-client-tls >=0.3.3.1 && <0.4 + , http-types >=0.9.1 && <0.10 + , lens >=4.15.3 && <5.0 + , req >=0.3.0 && <0.5 + , text >=1.2.2.1 && <1.3 + , unordered-containers >=0.2.8 && <0.3 + , servant-server >=0.9.1.1 && <0.12 + , warp >=3.2.11 && <3.3 + , hspec >=2.4.1 && <2.5 + other-modules: + Rakuten.Endpoints.IchibaSpec + Rakuten.Test.Class + Rakuten.Test.Client + Rakuten.Test.MockServer + Rakuten + Rakuten.Client + Rakuten.Endpoints + Rakuten.Endpoints.Ichiba + Rakuten.Types + Rakuten.Types.Base + Rakuten.Types.Class + Rakuten.Types.Error + Rakuten.Types.Ichiba + default-language: Haskell2010 diff --git a/src/Rakuten.hs b/src/Rakuten.hs new file mode 100644 --- /dev/null +++ b/src/Rakuten.hs @@ -0,0 +1,12 @@ +module Rakuten ( + -- * Define about Rakuten Client + module Rakuten.Client + -- * Endpoint function definitions + , module Rakuten.Endpoints + -- * Response and request param type definitions + , module Rakuten.Types + ) where + +import Rakuten.Client +import Rakuten.Endpoints +import Rakuten.Types diff --git a/src/Rakuten/Client.hs b/src/Rakuten/Client.hs new file mode 100644 --- /dev/null +++ b/src/Rakuten/Client.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Rakuten.Client ( + AppId + , RakutenClient + , defaultRaktenClient + , Client(..) + ) where + +import Control.Lens hiding ((:>)) +import Data.Default.Class (Default (def)) +import Data.Extensible +import Data.Function ((&)) +import Data.Text (Text) +import Network.HTTP.Req (Option, Scheme (Https), Url, https, (/:), + (=:)) +import Rakuten.Types + +type AppId = Text + +type RakutenClient = + Record '[ + "applicationId" ':> Text, + "affiliateId" ':> Maybe Text, + "callback" ':> Maybe Text, + "elements" ':> [Text] + ] + +defaultRaktenClient :: AppId -> RakutenClient +defaultRaktenClient appId = def & #applicationId .~ appId + +-- | +-- By using type class, the same functions can be used for mock servers and local hosts. +class Client a where + type ClientScheme a :: Scheme + baseUrl :: a -> Url (ClientScheme a) + mkHeader :: a -> Option scheme + +instance Client RakutenClient where + type ClientScheme RakutenClient = 'Https + baseUrl = const (https "app.rakuten.co.jp" /: "services" /: "api") + mkHeader = mappend ("format" =: ("json" :: Text)) . toParams diff --git a/src/Rakuten/Endpoints.hs b/src/Rakuten/Endpoints.hs new file mode 100644 --- /dev/null +++ b/src/Rakuten/Endpoints.hs @@ -0,0 +1,5 @@ +module Rakuten.Endpoints ( + module Rakuten.Endpoints.Ichiba + ) where + +import Rakuten.Endpoints.Ichiba diff --git a/src/Rakuten/Endpoints/Ichiba.hs b/src/Rakuten/Endpoints/Ichiba.hs new file mode 100644 --- /dev/null +++ b/src/Rakuten/Endpoints/Ichiba.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Rakuten.Endpoints.Ichiba + ( searchIchibaItem + , searchIchibaGenre + ) where + +import Data.Monoid ((<>)) +import Network.HTTP.Req (GET (..), JsonResponse, MonadHttp, + NoReqBody (..), jsonResponse, req, (/:)) +import Rakuten.Client +import Rakuten.Types + +searchIchibaItem :: (MonadHttp m, Client c) => + c -> IchibaItemSearchParam -> m (JsonResponse IchibaItems) +searchIchibaItem c param = req GET url NoReqBody jsonResponse option + where + url = baseUrl c /: "IchibaItem" /: "Search" /: "20170706" + option = mkHeader c <> toParams param + +searchIchibaGenre :: (MonadHttp m, Client c) => + c -> IchibaGenreSearchParam -> m (JsonResponse IchibaGenres) +searchIchibaGenre c param = req GET url NoReqBody jsonResponse option + where + url = baseUrl c /: "IchibaGenre" /: "Search" /: "20140222" + option = mkHeader c <> toParams param diff --git a/src/Rakuten/Types.hs b/src/Rakuten/Types.hs new file mode 100644 --- /dev/null +++ b/src/Rakuten/Types.hs @@ -0,0 +1,9 @@ +module Rakuten.Types + ( module Types + ) where + + +import Rakuten.Types.Base as Types +import Rakuten.Types.Class as Types +import Rakuten.Types.Error as Types +import Rakuten.Types.Ichiba as Types diff --git a/src/Rakuten/Types/Base.hs b/src/Rakuten/Types/Base.hs new file mode 100644 --- /dev/null +++ b/src/Rakuten/Types/Base.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Rakuten.Types.Base + ( ImageUrl + ) where + +import Data.Extensible +import Data.Text (Text) + +type ImageUrl = Record '[ "imageUrl" ':> Text ] diff --git a/src/Rakuten/Types/Class.hs b/src/Rakuten/Types/Class.hs new file mode 100644 --- /dev/null +++ b/src/Rakuten/Types/Class.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rakuten.Types.Class + ( ToParam(..) + , ToParams(..) + ) where + +import Control.Applicative (liftA2) +import Data.Aeson hiding (KeyValue) +import Data.Bool (bool) +import Data.Constraint +import Data.Default.Class (Default (..)) +import Data.Extensible +import Data.Functor.Identity (Identity (..)) +import qualified Data.HashMap.Strict as HM +import Data.Monoid (Endo (..), (<>)) +import Data.Proxy +import Data.String (fromString) +import Data.Text (Text) +import GHC.TypeLits (KnownSymbol, symbolVal) +import Network.HTTP.Req (QueryParam, (=:)) + +instance Forall (KeyValue KnownSymbol FromJSON) xs => FromJSON (Record xs) where + parseJSON = withObject "Object" $ + \v -> hgenerateFor (Proxy :: Proxy (KeyValue KnownSymbol FromJSON)) $ + \m -> let k = symbolVal (proxyAssocKey m) in + case HM.lookup (fromString k) v of + Just a -> Field . return <$> parseJSON a + Nothing -> fail $ "Missing key: " `mappend` k + +instance Forall (KeyValue KnownSymbol ToJSON) xs => ToJSON (Record xs) where + toJSON = Object . HM.fromList . flip appEndo [] . hfoldMap getConst' . hzipWith + (\(Comp Dict) -> Const' . Endo . (:) . + liftA2 (,) (fromString . symbolVal . proxyAssocKey) (toJSON . getField)) + (library :: Comp Dict (KeyValue KnownSymbol ToJSON) :* xs) + +instance Default a => Default (Identity a) where + def = Identity def + +instance Default Text where + def = mempty + +instance Forall (KeyValue KnownSymbol Default) xs => Default (Record xs) where + def = runIdentity $ hgenerateFor + (Proxy :: Proxy (KeyValue KnownSymbol Default)) (const $ pure (Field def)) + +class ToParam a where + toParam :: (QueryParam param, Monoid param) => Text -> a -> param + +instance ToParam Int where + toParam = (=:) + +instance ToParam Double where + toParam = (=:) + +instance ToParam Text where + toParam _ "" = mempty + toParam name txt = name =: txt + +instance ToParam Bool where + toParam name = (=:) name . bool 0 (1 :: Int) + +instance ToParam [Text] where + toParam _ [] = mempty + toParam name xs = name =: foldl1 (\acc s -> acc <> "," <> s) (fmap show xs) + +instance ToParam a => ToParam (Maybe a) where + toParam = maybe mempty . toParam + +instance ToParam a => ToParam (Identity a) where + toParam name = toParam name . runIdentity + +class ToParams a where + toParams :: (QueryParam param, Monoid param) => a -> param + +instance Forall (KeyValue KnownSymbol ToParam) xs => ToParams (Record xs) where + toParams = flip appEndo mempty . hfoldMap getConst' . hzipWith + (\(Comp Dict) -> Const' . Endo . (<>) . + liftA2 toParam (fromString . symbolVal . proxyAssocKey) getField) + (library :: Comp Dict (KeyValue KnownSymbol ToParam) :* xs) diff --git a/src/Rakuten/Types/Error.hs b/src/Rakuten/Types/Error.hs new file mode 100644 --- /dev/null +++ b/src/Rakuten/Types/Error.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} + +module Rakuten.Types.Error + ( RakutenError + ) where + +import Data.Extensible +import Data.Text (Text) + +-- | +-- when error, Rakuten is response: +-- { +-- "error": "wrong_parameter", +-- "error_description": "specify valid applicationId" +-- } + +type RakutenError = + Record '[ + "error" ':> Text, + "error_description" ':> Text + ] diff --git a/src/Rakuten/Types/Ichiba.hs b/src/Rakuten/Types/Ichiba.hs new file mode 100644 --- /dev/null +++ b/src/Rakuten/Types/Ichiba.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Rakuten.Types.Ichiba + ( -- Response JSON Type + IchibaItems + , ItemWrap + , Item + , IchibaGenres + -- Genre JSON Type + , Genre + , ParentGenre' + , ParentGenreWrap + , BrotherGenreWrap + , ChiledGenreWrap + , GenreInformation + , CurrentItemGenre + , ChiledItemGenre + -- Tag JSON Type + -- , Tag + , TagWrap + , TagGroup + , TagGroupWrap + , ItemTag + , ItemTagWrap + , ItemTagGroup + , ItemTagGroupWrap + -- Request Params Type + , IchibaItemSearchParam + , IchibaGenreSearchParam + ) where + +import Data.Extensible +import Data.Text (Text) +import Rakuten.Types.Base (ImageUrl) +import Rakuten.Types.Class () + +type IchibaItems = + Record '[ + "count" ':> Int, + "page" ':> Int, + "first" ':> Int, + "last" ':> Int, + "hits" ':> Int, + "carrier" ':> Int, + "pageCount" ':> Int, + "Items" ':> [ItemWrap], + "GenreInformation" ':> [GenreInformation], + "TagInformation" ':> [ItemTagGroupWrap] + ] + +type ItemWrap = Record '[ "Item" ':> Item ] + +type Item = + Record '[ + "itemName" ':> Text, + "catchcopy" ':> Text, + "itemCode" ':> Text, + "itemPrice" ':> Int, + "itemCaption" ':> Text, + "itemUrl" ':> Text, + "shopUrl" ':> Text, + "smallImageUrls" ':> [ImageUrl], + "mediumImageUrls" ':> [ImageUrl], + "affiliateUrl" ':> Text, + "shopAffiliateUrl" ':> Text, + "imageFlag" ':> Int, + "availability" ':> Int, + "taxFlag" ':> Int, + "postageFlag" ':> Int, + "creditCardFlag" ':> Int, + "shopOfTheYearFlag" ':> Int, + "shipOverseasFlag" ':> Int, + "shipOverseasArea" ':> Text, + "asurakuFlag" ':> Int, + "asurakuClosingTime" ':> Text, + "asurakuArea" ':> Text, + "affiliateRate" ':> Double, + "startTime" ':> Text, + "endTime" ':> Text, + "reviewCount" ':> Int, + "reviewAverage" ':> Double, + "pointRate" ':> Int, + "pointRateStartTime" ':> Text, + "pointRateEndTime" ':> Text, + "giftFlag" ':> Int, + "shopName" ':> Text, + "shopCode" ':> Text, + "genreId" ':> Text, + "tagIds" ':> [Int] + ] + +type GenreInformation = + Record '[ + "parent" ':> [ParentGenre'], + "current" ':> [CurrentItemGenre], + "chiled" ':> [ChiledItemGenre] + ] + +type ParentGenre' = + Record '[ + "genreId" ':> Text, + "genreName" ':> Text, + "genreLevel" ':> Int + ] + +type CurrentItemGenre = + Record '[ + "genreId" ':> Text, + "genreName" ':> Text, + "itemCount" ':> Int, + "genreLevel" ':> Int + ] + +type ChiledItemGenre = + Record '[ + "genreId" ':> Text, + "genreName" ':> Text, + "itemCount" ':> Int, + "genreLevel" ':> Int + ] + +type ItemTagGroupWrap = Record '[ "tagGroup" ':> ItemTagGroup ] + +type ItemTagGroup = + Record '[ + "tagGroupName" ':> Text, + "tagGroupId" ':> Int, + "tags" ':> [ItemTagWrap] + ] + +type ItemTagWrap = Record '[ "tag" ':> ItemTag ] + +type ItemTag = + Record '[ + "tagId" ':> Int, + "tagName" ':> Text, + "parentTagId" ':> Int, + "itemCount" ':> Int + ] + +type IchibaGenres = + Record '[ + "parents" ':> [ParentGenreWrap], + "current" ':> Genre, + "brothers" ':> [BrotherGenreWrap], + "children" ':> [ChiledGenreWrap], + "tagGroups" ':> [TagGroupWrap] + ] + +type Genre = + Record '[ + "genreId" ':> Int, + "genreName" ':> Text, + "genreLevel" ':> Int + ] + +type ParentGenreWrap = Record '[ "parent" ':> Genre ] + +type BrotherGenreWrap = Record '[ "brother" ':> Genre ] + +type ChiledGenreWrap = Record '[ "child" ':> Genre ] + +type TagGroupWrap = Record '[ "tagGroup" ':> TagGroup ] + +type TagGroup = + Record '[ + "tagGroupName" ':> Text, + "tagGroupId" ':> Int, + "tags" ':> [TagWrap] + ] + +type TagWrap = Record '[ "tag" ':> Tag ] + +type Tag = + Record '[ + "tagId" ':> Int, + "tagName" ':> Text, + "parentTagId" ':> Int + ] + +type IchibaItemSearchParam = + Record '[ + "keyword" ':> Text, + "shopCode" ':> Maybe Text, + "itemCode" ':> Maybe Text, + "genreId" ':> Maybe Int, + "tagId" ':> Maybe Int, + "hits" ':> Maybe Int, + "page" ':> Maybe Int, + "sort" ':> Maybe Text, + "minPrice" ':> Maybe Int, + "maxPrice" ':> Maybe Int, + "availability" ':> Maybe Bool, + "field" ':> Maybe Bool, + "carrier" ':> Maybe Bool, + "imageFlag" ':> Maybe Bool, + "orFlag" ':> Maybe Bool, + "NGKeyword" ':> Maybe Text, + "purchaseType" ':> Maybe Int, + "shipOverseasFlag" ':> Maybe Bool, + "shipOverseasArea" ':> Maybe Text, + "asurakuFlag" ':> Maybe Bool, + "asurakuArea" ':> Maybe Int, + "pointRateFlag" ':> Maybe Bool, + "pointRate" ':> Maybe Int, + "postageFlag" ':> Maybe Bool, + "creditCardFlag" ':> Maybe Bool, + "giftFlag" ':> Maybe Bool, + "hasReviewFlag" ':> Maybe Bool, + "maxAffiliateRate" ':> Maybe Double, + "minAffiliateRate" ':> Maybe Double, + "hasMovieFlag" ':> Maybe Bool, + "pamphletFlag" ':> Maybe Bool, + "appointDeliveryDateFlag" ':> Maybe Bool, + "genreInformationFlag" ':> Maybe Bool, + "tagInformationFlag" ':> Maybe Bool + ] + +type IchibaGenreSearchParam = + Record '[ + "genreId" ':> Int, + "genrePath" ':> Maybe Bool + ] diff --git a/test/Rakuten/Endpoints/IchibaSpec.hs b/test/Rakuten/Endpoints/IchibaSpec.hs new file mode 100644 --- /dev/null +++ b/test/Rakuten/Endpoints/IchibaSpec.hs @@ -0,0 +1,29 @@ +module Rakuten.Endpoints.IchibaSpec + ( main + , spec + ) where + +import Data.Default.Class (Default (def)) +import Network.HTTP.Req (responseBody, runReq) +import Rakuten.Endpoints.Ichiba (searchIchibaGenre, searchIchibaItem) +import Rakuten.Test.Class (TestData (..)) +import Rakuten.Test.Client (TestClient (..)) +import Rakuten.Test.MockServer (runMockServer) +import Test.Hspec (Spec, around_, context, describe, + hspec, it, shouldBe) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = around_ runMockServer $ do + describe "searchIchibaItem: endpoint GET /IchibaItem/Search/20170706" $ do + context "correct responce" $ do + it "should return IchibaItems response body" $ do + response <- runReq def $ searchIchibaItem (TestClient def) def + (responseBody response) `shouldBe` testData + describe "searchIchibaGenre: endpoint GET /IchibaGenre/Search/20140222" $ do + context "correct responce" $ do + it "should return IchibaGenres response body" $ do + response <- runReq def $ searchIchibaGenre (TestClient def) def + (responseBody response) `shouldBe` testData diff --git a/test/Rakuten/Test/Class.hs b/test/Rakuten/Test/Class.hs new file mode 100644 --- /dev/null +++ b/test/Rakuten/Test/Class.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Rakuten.Test.Class + ( TestData(..) + ) where + +import Data.Extensible +import Data.Functor.Identity (Identity (..)) +import Data.Proxy +import Data.Text (Text) +import GHC.TypeLits (KnownSymbol) + +class TestData a where + testData :: a + +instance TestData Int where + testData = 12345 + +instance TestData Double where + testData = 123.456 + +instance TestData Text where + testData = "abcdefg" + +instance TestData Bool where + testData = False + +instance (Applicative m, TestData a) => TestData (m a) where + testData = pure testData + +instance Forall (KeyValue KnownSymbol TestData) xs => TestData (Record xs) where + testData = runIdentity $ hgenerateFor + (Proxy :: Proxy (KeyValue KnownSymbol TestData)) (const $ pure (Field testData)) diff --git a/test/Rakuten/Test/Client.hs b/test/Rakuten/Test/Client.hs new file mode 100644 --- /dev/null +++ b/test/Rakuten/Test/Client.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Rakuten.Test.Client ( + TestClient(..) + ) where + +import Data.Text (Text) +import Network.HTTP.Req (Scheme (Http), http, port, (=:)) +import Rakuten.Client (Client (..), RakutenClient) +import Rakuten.Types (ToParams (toParams)) + +newtype TestClient = TestClient RakutenClient + +instance Client TestClient where + type ClientScheme TestClient = 'Http + baseUrl = const (http "localhost") + mkHeader (TestClient c) = + mconcat [port 8000, "format" =: ("json" :: Text), toParams c] diff --git a/test/Rakuten/Test/MockServer.hs b/test/Rakuten/Test/MockServer.hs new file mode 100644 --- /dev/null +++ b/test/Rakuten/Test/MockServer.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -fno-warn-unused-binds #-} + +module Rakuten.Test.MockServer + ( mockServer + , runMockServer + ) where + +import Rakuten.Test.Class +import Rakuten.Types +import Control.Concurrent +import Control.Exception +import Network.Wai.Handler.Warp +import Servant + +type RakutenHeader a = a + +type API = "IchibaItem" :> "Search" :> "20170706" :> Get '[JSON] (RakutenHeader IchibaItems) + :<|> "IchibaGenre" :> "Search" :> "20140222" :> Get '[JSON] (RakutenHeader IchibaGenres) + +api :: Proxy API +api = Proxy + +server :: Server API +server = searchIchibaItem + :<|> searchIchibaGenre + where + searchIchibaItem = return testData + searchIchibaGenre = return testData + +mockServer :: IO () +mockServer = run 8000 (serve api server) + +runMockServer :: IO () -> IO () +runMockServer action = do + tid <- forkIO mockServer + action `finally` killThread tid diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}