initial version with basic model - todo implement logic

added a swagger-generator

deriving coupontype automatically

implemented cors for swagger to work

fixed product model

.directory

@@ -0,0 +1,4 @@
+[Dolphin]
+Timestamp=2017,5,3,7,47,12
+Version=4
+ViewMode=1

.gitignore

@@ -0,0 +1,26 @@
+
+# Created by https://www.gitignore.io/api/haskell
+
+### Haskell ###
+dist
+dist-*
+cabal-dev
+*.o
+*.hi
+*.chi
+*.chs.h
+*.dyn_o
+*.dyn_hi
+.hpc
+.hsenv
+.cabal-sandbox/
+cabal.sandbox.config
+*.prof
+*.aux
+*.hp
+*.eventlog
+.stack-work/
+cabal.project.local
+.HTF/
+
+# End of https://www.gitignore.io/api/haskell

.vscode/settings.json

@@ -0,0 +1,3 @@
+// Place your settings in this file to overwrite default and user settings.
+{
+}

LICENSE

@@ -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

@@ -0,0 +1 @@
+# coupon-servant

SPEC.md

@@ -0,0 +1,23 @@
+Imagine the backend API of a typical coupon module that would be getting used in shopping cart applications. 
+End-customers would typically be discovering these coupons via some promotion or deal sites (like CouponRaja or CouponDunia).
+Entering this coupon during the checkout process would give the customer some discount.
+
+* Design & implement a REST API to create and read coupons.
+
+* We should be able to define the applicable discount based on
+-- Flat discount amount per order
+-- Flat discount amount per item
+-- Percentage discount on total order amount
+
+* We should be able to restrict coupon usage based on the following
+-- All products or list of products
+-- Orders placed between given start/end dates
+-- Orders with total amount higher than given value
+-- Limit coupon usage per customer (tracked by customer email), i.e. customer is allowed to use a coupon on 'N' times
+-- Limit coupon usage per product, i.e. coupon is allowed to be used 'N' number of times for a given product(s)
+-- Limit coupon usage, i.e. coupon is allowed to be used 'N' number of times across all customers and products
+
+* Design & implement a REST API to validate coupon usage and respond with the final discount amount. 
+The API can accept a list of items/products added to the shopping card,
+and the coupon that the customer is trying to apply. 
+The API should respond with whether the coupon is applicable or not, and discount amount.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

app/Main.hs

@@ -0,0 +1,11 @@
+module Main where
+
+import           App
+
+import           SwaggerGen
+
+main :: IO ()
+main = do genSwaggerDoc
+          run "host=localhost port=5432 user=msfuser dbname=coupon password="
+
+-- run "testSql.db"

coupon-servant.cabal

@@ -0,0 +1,70 @@
+name:                coupon-servant
+version:             0.1.0.0
+-- synopsis:
+-- description:
+homepage:            https://github.com/alaudiadae/coupon-servant#readme
+license:             BSD3
+license-file:        LICENSE
+author:              Author name here
+maintainer:          alaudiadae@gmx.com
+copyright:           2017 Author name here
+category:            Web
+build-type:          Simple
+extra-source-files:  README.md
+cabal-version:       >=1.10
+
+library
+  hs-source-dirs:      src
+  exposed-modules:     Lib,
+                       Api,
+                       App,
+                       Coupon,
+                       Models,
+                       SwaggerGen
+  build-depends:       base >= 4.7 && < 5
+                     , aeson
+                     , bytestring
+                     , lens
+                     , monad-logger
+                     , persistent
+                     , persistent-template
+                     , persistent-sqlite
+                     , persistent-postgresql
+                     , servant
+                     , servant-server
+                     , servant-swagger
+                     , string-conversions
+                     , swagger2
+                     , text
+                     , time
+                     , transformers
+                     , unordered-containers
+                     , wai
+                     , wai-cors
+                     , warp
+  default-language:    Haskell2010
+
+executable coupon-servant-exe
+  hs-source-dirs:      app
+  main-is:             Main.hs
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  build-depends:       base
+                     , coupon-servant
+  default-language:    Haskell2010
+
+test-suite coupon-servant-test
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      test
+  main-is:             Spec.hs
+  build-depends:       base
+                     , coupon-servant
+                     , hspec
+                     , hspec-wai
+                     , hspec-wai-json
+                     , aeson
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  default-language:    Haskell2010
+
+source-repository head
+  type:     git
+  location: https://github.com/githubuser/coupon-servant

src/Api.hs

@@ -0,0 +1,24 @@
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies      #-}
+{-# LANGUAGE TypeOperators     #-}
+
+module Api (module Api,module Models) where
+
+import           Data.Proxy
+import           Data.Text
+import           Models
+import           Servant.API
+
+type CouponApi =
+       "coupon" :> "add" :> ReqBody '[JSON] Coupon :> Post '[JSON] (Maybe Coupon)
+  :<|> "coupon" :> "get" :> Capture "name" Text  :> Get  '[JSON] (Maybe Coupon)
+  :<|> "coupon" :> "del" :> Capture "name" Text  :> Get  '[JSON] (Maybe Coupon)
+
+type BillCouponApi =
+       "billcoupon" :> ReqBody '[JSON] BillCoupon :> Post '[JSON] CouponResult
+
+type ServerApi = CouponApi :<|> BillCouponApi
+
+api :: Proxy ServerApi
+api = Proxy

src/App.hs

@@ -0,0 +1,80 @@
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies      #-}
+{-# LANGUAGE TypeOperators     #-}
+
+module App where
+
+import           Api
+import           Control.Monad.IO.Class
+import           Control.Monad.Logger        (runStderrLoggingT)
+import           Data.String.Conversions
+import           Data.Text
+import           Database.Persist
+import           Database.Persist.Postgresql
+import           Database.Persist.Sqlite
+import           Network.Wai
+import           Network.Wai.Handler.Warp    as Warp
+import           Network.Wai.Middleware.Cors
+import           Servant
+-- import           Network.Wai.Middleware.RequestLogger (logStdoutDev)
+
+couponServer :: ConnectionPool -> Server CouponApi
+couponServer pool =
+  couponAddH :<|> couponGetH :<|> couponDelH
+  where
+    couponAddH newCoupon = liftIO $ couponAdd newCoupon
+    couponGetH code    = liftIO $ couponGet code
+    couponDelH code    = liftIO $ couponDel code
+
+    couponAdd :: Coupon -> IO (Maybe Coupon)
+    couponAdd newCoupon = flip runSqlPersistMPool pool $ do
+      exists <- selectFirst [CouponCode ==. couponCode newCoupon] []
+      case exists of
+        Nothing -> Just <$> insert newCoupon
+        Just _  -> return Nothing
+      return Nothing
+
+    couponGet :: Text -> IO (Maybe Coupon)
+    couponGet code = flip runSqlPersistMPool pool $ do
+      mUser <- selectFirst [CouponCode ==. code] []
+      return $ entityVal <$> mUser
+
+    couponDel :: Text -> IO (Maybe Coupon)
+    couponDel code = flip runSqlPersistMPool pool $ do
+      deleteWhere [CouponCode ==. code]
+      return Nothing
+
+billCouponServer :: ConnectionPool -> Server BillCouponApi
+billCouponServer pool = billCouponComputeH
+                        where billCouponComputeH bill = liftIO $ billCouponCompute bill
+                                                        -- return $ Applied 100
+                              billCouponCompute :: BillCoupon -> IO CouponResult
+                              billCouponCompute bill = do putStrLn $ show bill
+                                                          return $ Applied 100
+
+
+server :: ConnectionPool -> Server ServerApi
+server pool = couponServer pool :<|> billCouponServer pool
+
+
+app :: ConnectionPool -> Application
+app pool = cors (const $ Just policy) $ serve api $ server pool
+            where
+               policy = simpleCorsResourcePolicy { corsRequestHeaders = ["Content-Type"] }
+
+mkPgApp :: String -> IO Application
+mkPgApp sqliteFile = do
+  pool <- runStderrLoggingT $ createPostgresqlPool (cs sqliteFile) 5
+  runSqlPool (runMigration migrateAll) pool
+  return $ app pool
+
+mkApp :: String -> IO Application
+mkApp sqliteFile = do
+  pool <- runStderrLoggingT $ createSqlitePool (cs sqliteFile) 5
+  runSqlPool (runMigration migrateAll) pool
+  return $ app pool
+
+run :: String -> IO ()
+run dbConnStr =
+  Warp.run 3000 =<< mkPgApp dbConnStr

src/Coupon.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE DeriveAnyClass             #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE EmptyDataDecls             #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE QuasiQuotes                #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE TypeFamilies               #-}
+
+module Coupon where
+
+import           Data.Aeson
+import           Data.Aeson.Types
+import           Database.Persist.TH
+import           GHC.Generics
+import           Prelude
+
+
+data Product = Product {
+  productName  :: String,
+  productPrice:: Int
+}  deriving (Eq, Read, Show, Generic, FromJSON, ToJSON)
+
+data BillCoupon = BillCoupon {
+  customer    :: String,
+  coupon      :: String,
+  productList :: [Product]
+} deriving (Eq, Read, Show, Generic, FromJSON, ToJSON)
+
+data CouponResult = Applied Int | Rejected String | Partial String
+    deriving (Show, Read, Eq, Generic, FromJSON, ToJSON)
+
+data CouponType = ProductFlat Int | CartFlat Int | CartPercent Int
+    deriving (Show, Read, Eq, Generic)
+
+couponOption =  defaultOptions { sumEncoding   = ObjectWithSingleField }
+
+instance FromJSON CouponType where
+    parseJSON = genericParseJSON couponOption
+
+instance ToJSON CouponType where
+    toJSON = genericToJSON couponOption
+
+derivePersistField "CouponType"
+
+prodListEx = [Product {productName = "Water", productPrice = 15}]
+billCouponExample = BillCoupon { customer = "test@email.com", coupon = "FLAT100", productList = prodListEx}

src/Lib.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE DataKinds       #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeOperators   #-}
+module Lib
+    ( startApp
+    , app
+    ) where
+
+import Data.Aeson
+import Data.Aeson.TH
+import Network.Wai
+import Network.Wai.Handler.Warp
+import Servant
+
+data User = User
+  { userId        :: Int
+  , userFirstName :: String
+  , userLastName  :: String
+  } deriving (Eq, Show)
+
+$(deriveJSON defaultOptions ''User)
+
+type API = "users" :> Get '[JSON] [User]
+
+startApp :: IO ()
+startApp = run 8080 app
+
+app :: Application
+app = serve api server
+
+api :: Proxy API
+api = Proxy
+
+server :: Server API
+server = return users
+
+users :: [User]
+users = [ User 1 "Isaac" "Newton"
+        , User 2 "Albert" "Einstein"
+        ]

src/Models.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE EmptyDataDecls             #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE QuasiQuotes                #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE TypeFamilies               #-}
+
+module Models (module Models,module Coupon) where
+
+import           Coupon
+import           Data.Aeson
+import           Data.Text
+import           Data.Time.Clock
+import           Database.Persist.TH
+import           GHC.Generics
+
+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
+Customer
+  email Text
+  UniqueEmail email
+  Primary email
+  deriving Eq Read Show Generic
+-- Product
+--   name Text
+--   price Int
+--   code Text
+--   UniqueName name
+--   Foreign Coupon fkcoupon code
+--   Primary name
+--   deriving Eq Read Show Generic
+Coupon json
+  code Text
+  value  CouponType
+  min_price Int
+  customer_limit Int
+  usage_limit Int
+  valid_from UTCTime default=now()
+  valid_till UTCTime default=now()
+  UniqueCode code
+  Primary code
+  deriving Eq Read Show Generic
+|]

src/SwaggerGen.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE TypeOperators              #-}
+
+module SwaggerGen where
+
+import           Api
+import           Control.Lens
+import           Data.Aeson
+import           Data.Aeson.Types           (camelTo2)
+import qualified Data.ByteString.Lazy.Char8 as BL8
+import           Data.Swagger
+import           Servant.Swagger
+
+modifier :: String -> String
+modifier = drop 1 . dropWhile (/= '_') . camelTo2 '_'
+
+prefixSchemaOptions :: SchemaOptions
+prefixSchemaOptions = defaultSchemaOptions { fieldLabelModifier = modifier }
+
+instance ToSchema BillCoupon    where declareNamedSchema = genericDeclareNamedSchema prefixSchemaOptions
+instance ToSchema CouponType where declareNamedSchema = genericDeclareNamedSchema prefixSchemaOptions
+instance ToSchema Coupon    where declareNamedSchema = genericDeclareNamedSchema prefixSchemaOptions
+instance ToSchema Product where declareNamedSchema = genericDeclareNamedSchema prefixSchemaOptions
+instance ToSchema Customer     where declareNamedSchema = genericDeclareNamedSchema prefixSchemaOptions
+instance ToSchema CouponResult     where declareNamedSchema = genericDeclareNamedSchema prefixSchemaOptions
+
+swaggerDoc :: Swagger
+swaggerDoc = toSwagger api
+  & host ?~ "localhost:3000"
+  & info.title .~ "Coupon Api"
+  & info.version .~ "v1"
+
+genSwaggerDoc :: IO ()
+genSwaggerDoc = BL8.writeFile "swagger.json" (encode swaggerDoc)

stack.yaml

@@ -0,0 +1,66 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# http://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+# resolver: ghcjs-0.1.0_ghc-7.10.2
+# resolver:
+#  name: custom-snapshot
+#  location: "./custom-snapshot.yaml"
+resolver: lts-8.13
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+# - location:
+#    git: https://github.com/commercialhaskell/stack.git
+#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#   extra-dep: true
+#  subdirs:
+#  - auto-update
+#  - wai
+#
+# A package marked 'extra-dep: true' will only be built if demanded by a
+# non-dependency (i.e. a user package), and its test suites and benchmarks
+# will not be run. This is useful for tweaking upstream packages.
+packages:
+- '.'
+# Dependency packages to be pulled from upstream that are not in the resolver
+# (e.g., acme-missiles-0.3)
+extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+flags: {}
+
+# Extra package databases containing global packages
+extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=1.4"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor

swagger.json

@@ -0,0 +1 @@
+{"swagger":"2.0","info":{"version":"v1","title":"Coupon Api"},"host":"localhost:3000","paths":{"/coupon/add":{"post":{"consumes":["application/json"],"produces":["application/json"],"parameters":[{"required":true,"schema":{"$ref":"#/definitions/Coupon"},"in":"body","name":"body"}],"responses":{"400":{"description":"Invalid `body`"},"200":{"schema":{"$ref":"#/definitions/Coupon"},"description":""}}}},"/coupon/get/{name}":{"get":{"produces":["application/json"],"parameters":[{"required":true,"in":"path","name":"name","type":"string"}],"responses":{"404":{"description":"`name` not found"},"200":{"schema":{"$ref":"#/definitions/Coupon"},"description":""}}}},"/coupon/del/{name}":{"get":{"produces":["application/json"],"parameters":[{"required":true,"in":"path","name":"name","type":"string"}],"responses":{"404":{"description":"`name` not found"},"200":{"schema":{"$ref":"#/definitions/Coupon"},"description":""}}}},"/billcoupon":{"post":{"consumes":["application/json"],"produces":["application/json"],"parameters":[{"required":true,"schema":{"$ref":"#/definitions/BillCoupon"},"in":"body","name":"body"}],"responses":{"400":{"description":"Invalid `body`"},"200":{"schema":{"$ref":"#/definitions/CouponResult"},"description":""}}}}},"definitions":{"Coupon":{"required":["code","value","min_price","valid_from","valid_till"],"properties":{"code":{"type":"string"},"value":{"$ref":"#/definitions/CouponType"},"min_price":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"},"valid_from":{"$ref":"#/definitions/UTCTime"},"valid_till":{"$ref":"#/definitions/UTCTime"}},"type":"object"},"CouponType":{"properties":{"ProductFlat":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"},"CartFlat":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"},"CartPercent":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"}},"maxProperties":1,"minProperties":1,"type":"object"},"UTCTime":{"example":"2016-07-22T00:00:00Z","format":"yyyy-mm-ddThh:MM:ssZ","type":"string"},"CouponResult":{"properties":{"Applied":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"},"Rejected":{"type":"string"},"Partial":{"type":"string"}},"maxProperties":1,"minProperties":1,"type":"object"},"BillCoupon":{"required":["list"],"properties":{"list":{"items":{"type":"string"},"type":"array"}},"minItems":1,"items":[{"type":"string"}],"maxItems":1,"type":"object"}}}

test/Spec.hs

@@ -0,0 +1,20 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Main (main) where
+
+import Lib (app)
+import Test.Hspec
+import Test.Hspec.Wai
+import Test.Hspec.Wai.JSON
+
+main :: IO ()
+main = hspec spec
+
+spec :: Spec
+spec = with (return app) $ do
+    describe "GET /users" $ do
+        it "responds with 200" $ do
+            get "/users" `shouldRespondWith` 200
+        it "responds with [User]" $ do
+            let users = "[{\"userId\":1,\"userFirstName\":\"Isaac\",\"userLastName\":\"Newton\"},{\"userId\":2,\"userFirstName\":\"Albert\",\"userLastName\":\"Einstein\"}]"
+            get "/users" `shouldRespondWith` users