initial version with basic model - todo implement logic

added a swagger-generator

deriving coupontype automatically

implemented cors for swagger to work

fixed product model

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)