added a debug/release app

app/Main.hs

@@ -5,4 +5,3 @@ import           App
 main :: IO ()
 main = run "host=localhost port=5432 user=msfuser dbname=coupon password="
 
--- run "testSql.db"

coupon-servant.cabal

@@ -41,6 +41,7 @@ library
                      , unordered-containers
                      , wai
                      , wai-cors
+                     , wai-extra
                      , warp
   default-language:    Haskell2010
 

src/Api.hs

@@ -10,12 +10,11 @@ import           Data.Swagger
 import           Data.Text
 import           Models
 import           Servant.API
-import           SwaggerGen
 
 type CouponApi =
-       "coupon" :> "add" :> ReqBody '[JSON] Coupon :> Post '[JSON] (Maybe Coupon)
+       "coupon" :> "add" :> ReqBody '[JSON] Coupon :> Post '[JSON] NoContent
   :<|> "coupon" :> "get" :> Capture "name" Text  :> Get  '[JSON] (Maybe Coupon)
-  :<|> "coupon" :> "del" :> Capture "name" Text  :> Get  '[JSON] (Maybe Coupon)
+  :<|> "coupon" :> "del" :> Capture "name" Text  :> Get  '[JSON] NoContent
 
 type BillCouponApi =
        "billcoupon" :> ReqBody '[JSON] BillCoupon :> Post '[JSON] CouponResult

src/App.hs

@@ -6,8 +6,10 @@
 module App where
 
 import           Api
+import           Control.Monad
 import           Control.Monad.IO.Class
 import           Control.Monad.Logger                 (runStderrLoggingT)
+import           Data.Maybe
 import           Data.String.Conversions
 import           Data.Text
 import           Database.Persist
@@ -16,9 +18,9 @@ import           Database.Persist.Sqlite
 import           Network.Wai
 import           Network.Wai.Handler.Warp             as Warp
 import           Network.Wai.Middleware.Cors
+import           Network.Wai.Middleware.RequestLogger (logStdoutDev)
 import           Servant
 import           SwaggerGen
--- import           Network.Wai.Middleware.RequestLogger (logStdoutDev)
 
 couponServer :: ConnectionPool -> Server CouponApi
 couponServer pool =
@@ -28,28 +30,25 @@ couponServer pool =
     couponGetH code    = liftIO $ couponGet code
     couponDelH code    = liftIO $ couponDel code
 
-    couponAdd :: Coupon -> IO (Maybe Coupon)
+    couponAdd :: Coupon -> IO NoContent
     couponAdd newCoupon = flip runSqlPersistMPool pool $ do
       exists <- selectFirst [CouponCode ==. couponCode newCoupon] []
-      case exists of
+      when (isNothing exists) $ void $ insert newCoupon
-        Nothing -> Just <$> insert newCoupon
+      return NoContent
-        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 :: Text -> IO NoContent
     couponDel code = flip runSqlPersistMPool pool $ do
       deleteWhere [CouponCode ==. code]
-      return Nothing
+      return NoContent
 
 billCouponServer :: ConnectionPool -> Server BillCouponApi
-billCouponServer _ = billCouponComputeH
+billCouponServer _ = liftIO.billCouponCompute
-                        where billCouponComputeH bill = liftIO $ billCouponCompute bill
+                    where billCouponCompute bill = do print bill
-                              billCouponCompute bill = do print bill
                                                       return $ Applied 100
 
 swaggerServer :: Server SwaggerApi
@@ -60,21 +59,29 @@ server pool = couponServer pool :<|> billCouponServer pool :<|> swaggerServer
 
 
 app :: ConnectionPool -> Application
-app pool = cors (const $ Just policy) $ serve api $ server pool
+app pool = serve couponApi $ couponServer pool :<|> billCouponServer pool
-            where
-               policy = simpleCorsResourcePolicy { corsRequestHeaders = ["Content-Type"] }
 
-mkPgApp :: String -> IO Application
+appDebug :: ConnectionPool -> Application
-mkPgApp sqliteFile = do
+appDebug pool = logStdoutDev $ cors (const $ Just policy) $ serve api $ server pool
+            where policy = simpleCorsResourcePolicy { corsRequestHeaders = ["Content-Type"] }
+
+mkApp :: String -> IO Application
+mkApp sqliteFile = do
   pool <- runStderrLoggingT $ createPostgresqlPool (cs sqliteFile) 5
   runSqlPool (runMigration migrateAll) pool
   return $ app pool
 
-mkApp :: String -> IO Application
+mkDebugPgApp :: String -> IO Application
-mkApp sqliteFile = do
+mkDebugPgApp sqliteFile = do
+  pool <- runStderrLoggingT $ createPostgresqlPool (cs sqliteFile) 5
+  runSqlPool (runMigration migrateAll) pool
+  return $ appDebug pool
+
+mkSqliteApp :: String -> IO Application
+mkSqliteApp sqliteFile = do
   pool <- runStderrLoggingT $ createSqlitePool (cs sqliteFile) 5
   runSqlPool (runMigration migrateAll) pool
-  return $ app pool
+  return $ appDebug pool
 
 run :: String -> IO ()
-run dbConnStr = Warp.run 3000 =<< mkPgApp dbConnStr
+run dbConnStr = Warp.run 3000 =<< mkApp dbConnStr

src/Coupon.hs

@@ -31,7 +31,7 @@ data BillCoupon = BillCoupon {
   productList :: [Product]
 } deriving (Eq, Read, Show, Generic, FromJSON, ToJSON, ToSchema)
 
-data CouponResult = Applied Int | Rejected String | Partial String
+data CouponResult = Applied Int | Rejected String
     deriving (Show, Read, Eq, Generic, FromJSON, ToJSON, ToSchema)
 
 data CouponForProduct = CouponForProduct {
@@ -52,12 +52,3 @@ instance ToJSON CouponType where
     toJSON = genericToJSON couponOption
 
 derivePersistField "CouponType"
-
--- prodListEx :: [Product]
--- prodListEx = [Product {productName = "Water", productPrice = 15}]
-
--- billCouponExample :: BillCoupon
--- billCouponExample = BillCoupon { customer = "test@email.com",
---                                  coupon = "FLAT100",
---                                  productList = prodListEx }
-

src/Models.hs

@@ -43,6 +43,7 @@ Coupon json
   min_price Int
   customer_limit Int
   usage_limit Int
+  used Int
   valid_from UTCTime default=now()
   valid_till UTCTime default=now()
   UniqueCode code

src/SwaggerGen.hs

@@ -25,23 +25,9 @@ prefixSchemaOptions = defaultSchemaOptions { fieldLabelModifier = modifier }
 
 instance ToSchema Coupon where declareNamedSchema = genericDeclareNamedSchema prefixSchemaOptions
 
-
--- swaggerDoc :: Swagger
 swaggerDoc :: HasSwagger api => Proxy api -> Swagger
 swaggerDoc api = toSwagger api
   & host ?~ Host {_hostName = "localhost",_hostPort = Just 3000}
   & info.title .~ "Coupon Api"
   & info.version .~ "v1"
-  -- & applyTagsFor billOp ["billcoupon" & description ?~ "Text"]
 
--- genSwaggerDoc :: IO ()
--- genSwaggerDoc = BL8.writeFile "swagger.json" (encode swaggerDoc)
-
--- billOp :: Traversal' Swagger Operation
--- billOp = subOperations (Proxy :: Proxy BillCouponApi) (Proxy :: Proxy ServerApi)
-
--- billText :: T.Text
--- billText = cs $ encode billCouponExample
-
--- billCouponSchema :: BL8.ByteString
--- billCouponSchema = encode $ toSchema (Proxy::Proxy BillCoupon)