summaryrefslogtreecommitdiff
path: root/src/Shop/Handler.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Shop/Handler.hs')
-rw-r--r--src/Shop/Handler.hs56
1 files changed, 56 insertions, 0 deletions
diff --git a/src/Shop/Handler.hs b/src/Shop/Handler.hs
new file mode 100644
index 0000000..c3b0eda
--- /dev/null
+++ b/src/Shop/Handler.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Shop.Handler where
+
+import Control.Monad.Logger (LoggingT, runStdoutLoggingT,
+ logInfo, logWarn)
+import Formatting (format, (%), fixed)
+--import Formatting.Formatters (fixed)
+import Shop.Config
+import Shop.Types
+import Protolude hiding (product, (%))
+import Servant (throwError)
+import Servant.Server (ServantErr(..), err500, (:~>)(..))
+import qualified Servant.Server.Internal.Handler as SH
+
+
+type Handler = LoggingT SH.Handler
+
+type App = ReaderT Config Handler
+
+runHandler :: Handler a -> (a -> Handler a) -> (ServantErr -> Handler a) -> Handler a
+runHandler ha fa ferr = do
+ ha' <- liftIO $ runHandlerIO ha
+ case ha' of
+ Right a -> fa a
+ Left err -> ferr err
+
+appToInternalHandler :: Config -> App :~> SH.Handler
+appToInternalHandler cfg = NT appHandlerToHandler'
+ where
+ appHandlerToHandler' :: App a -> SH.Handler a
+ appHandlerToHandler' h = runStdoutLoggingT $ runReaderT h cfg
+
+runHandlerIO :: Handler a -> IO (Either ServantErr a)
+runHandlerIO = SH.runHandler . runStdoutLoggingT
+
+handlerToApp :: Handler a -> App a
+handlerToApp = lift
+
+charge :: ChargeForm -> App ChargeResponse
+charge chargeform = do
+ cfg <- ask
+ -- TODO: send email
+ let cid = "TODO"
+ a = "TODO"
+ $(logInfo) $ "Charge successfully created: \"" <> email chargeform <> "\" (" <> showPrice total <> ")"
+ return $ ChargeResponse cid a
+ where
+ total = foldl (\n a -> n + quantity a * prix (product a)) 0 (articles chargeform)
+
+showPrice :: Int -> Text
+showPrice p = toS $ format (fixed 2) (fromIntegral p / 100) <> "€"