summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Shop/API.hs16
-rw-r--r--src/Shop/Config.hs90
-rw-r--r--src/Shop/Handler.hs56
-rw-r--r--src/Shop/Server.hs49
-rw-r--r--src/Shop/Types.hs56
5 files changed, 267 insertions, 0 deletions
diff --git a/src/Shop/API.hs b/src/Shop/API.hs
new file mode 100644
index 0000000..d934a0d
--- /dev/null
+++ b/src/Shop/API.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeOperators #-}
+module Shop.API where
+
+import Protolude
+import Data.Proxy (Proxy (..))
+import Servant.API
+import Shop.Types
+
+
+type ShopAPI =
+ "charge" :> ReqBody '[JSON] ChargeForm :> Post '[JSON] ChargeResponse
+
+shopAPI :: Proxy ShopAPI
+shopAPI = Proxy
diff --git a/src/Shop/Config.hs b/src/Shop/Config.hs
new file mode 100644
index 0000000..7c79e28
--- /dev/null
+++ b/src/Shop/Config.hs
@@ -0,0 +1,90 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Shop.Config where
+
+import Protolude
+import Control.Monad.Logger (MonadLogger,
+ runNoLoggingT,
+ runStdoutLoggingT)
+import Control.Monad.Trans.Control (MonadBaseControl)
+import Network.Wai (Middleware)
+import Network.Wai.Middleware.RequestLogger (logStdout, logStdoutDev)
+import Network.Wai.Handler.Warp (HostPreference)
+import System.Environment (lookupEnv, setEnv)
+import Path
+import Data.ByteString.Char8 (pack)
+import GHC.Show (Show(..))
+
+
+data Environment =
+ Development
+ | Test
+ | Production
+ deriving (Eq, Show, Read)
+
+setLogger :: Environment -> Middleware
+setLogger Test = identity
+setLogger Development = logStdoutDev
+setLogger Production = logStdout
+
+data Config = Config
+ { getConfigEnv :: !Environment
+ , getConfigHost :: !HostPreference
+ , getConfigPort :: !Int
+ , getConfigSocket :: !(Maybe FilePath)
+ , getConfigUrlPath :: !Text
+ }
+
+data ConfigMonoid = ConfigMonoid
+ { configMonoidEnv :: !(Maybe Environment)
+ , configMonoidHost :: !(Maybe HostPreference)
+ , configMonoidPort :: !(Maybe Int)
+ , configMonoidSocket :: !(Maybe FilePath)
+ , configMonoidUrlPath :: !(Maybe Text)
+ } deriving Show
+
+instance Monoid ConfigMonoid where
+ mempty = ConfigMonoid
+ { configMonoidEnv = Nothing
+ , configMonoidHost = Nothing
+ , configMonoidPort = Nothing
+ , configMonoidSocket = Nothing
+ , configMonoidUrlPath = Nothing
+ }
+ mappend l r = ConfigMonoid
+ { configMonoidEnv = configMonoidEnv l <|> configMonoidEnv r
+ , configMonoidHost = configMonoidHost l <|> configMonoidHost r
+ , configMonoidPort = configMonoidPort l <|> configMonoidPort r
+ , configMonoidSocket = configMonoidSocket l <|> configMonoidSocket r
+ , configMonoidUrlPath = configMonoidUrlPath l <|> configMonoidUrlPath r
+ }
+
+configMonoidToConfig :: ConfigMonoid -> Config
+configMonoidToConfig c = Config
+ { getConfigEnv = fromMaybe Production (configMonoidEnv c)
+ , getConfigHost = fromMaybe "127.0.0.1" (configMonoidHost c)
+ , getConfigPort = fromMaybe 8080 (configMonoidPort c)
+ , getConfigSocket = configMonoidSocket c
+ , getConfigUrlPath = fromMaybe "" (configMonoidUrlPath c)
+ }
+
+getEnvConfig :: IO ConfigMonoid
+getEnvConfig = do
+ env <- lookupEnv "SHOP_ENV"
+ host <- lookupEnv "SHOP_HOST"
+ port <- lookupEnv "SHOP_PORT"
+ socket <- lookupEnv "SHOP_SOCKET"
+ urlpath <- lookupEnv "SHOP_URLPATH"
+ return $ mempty
+ { configMonoidEnv = readMaybe =<< env
+ , configMonoidHost = readMaybe =<< host
+ , configMonoidPort = readMaybe =<< port
+ , configMonoidSocket = socket
+ , configMonoidUrlPath = readMaybe =<< urlpath
+ }
+
+getConfig :: IO Config
+getConfig = do
+ envconfig <- getEnvConfig
+ return $ configMonoidToConfig envconfig
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) <> "€"
diff --git a/src/Shop/Server.hs b/src/Shop/Server.hs
new file mode 100644
index 0000000..21d0d65
--- /dev/null
+++ b/src/Shop/Server.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeOperators #-}
+module Shop.Server where
+
+import Shop.API
+import Shop.Config
+import Shop.Types
+import Shop.Handler
+import qualified Control.Category as Category
+import Control.Monad.Logger (runStdoutLoggingT)
+import Protolude
+import Servant.API
+import Servant.Server hiding (Handler)
+import Network.Socket
+import Network.Wai.Handler.Warp (defaultSettings,
+ runSettings,
+ runSettingsSocket,
+ setHost,
+ setPort)
+
+
+server :: ServerT ShopAPI App
+server = charge
+
+app :: Config -> Application
+app cfg = serve shopAPI (readerServer cfg)
+
+readerServer :: Config -> Server ShopAPI
+readerServer cfg = appToInternalHandler cfg `enter` server
+
+serveApp :: (Config -> Application) -> IO ()
+serveApp f = do
+ cfg <- getConfig
+ let logger = setLogger (getConfigEnv cfg)
+ let settings = setHost (getConfigHost cfg) $
+ setPort (getConfigPort cfg) defaultSettings
+ case getConfigSocket cfg of
+ Nothing -> runSettings settings (logger $ f cfg)
+ Just s -> do
+ sock <- socket AF_UNIX Stream 0
+ bind sock $ SockAddrUnix "shop-server.sock"
+ listen sock maxListenQueue
+ runSettingsSocket settings sock (logger $ f cfg)
+ close sock
+
+main :: IO ()
+main = serveApp app
diff --git a/src/Shop/Types.hs b/src/Shop/Types.hs
new file mode 100644
index 0000000..c2ddaa5
--- /dev/null
+++ b/src/Shop/Types.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE DeriveGeneric #-}
+module Shop.Types
+ ( Product(..)
+ , Article(..)
+ , ChargeForm(..)
+ , ChargeResponse(..)
+ )
+ where
+
+import Protolude hiding (Product(..))
+import Data.Aeson (ToJSON(..), FromJSON(..), Value(..))
+import Servant.API
+
+
+data ChargeResponse = ChargeResponse
+ { chargeid :: Text
+ , chargeamount :: Text
+ }
+ deriving (Show, Read, Generic, Eq)
+
+instance ToJSON ChargeResponse
+instance FromJSON ChargeResponse
+
+data Product = Product
+ { nom :: Text
+ , description :: Text
+ , poids :: Int
+ -- ^ poids en grammes
+ , prix :: Int
+ -- ^ prix en centimes d'euros
+ }
+ deriving (Show, Read, Generic, Eq)
+
+instance ToJSON Product
+instance FromJSON Product
+
+data Article = Article
+ { product :: Product
+ , quantity :: Int
+ }
+ deriving (Show, Read, Generic, Eq)
+
+instance ToJSON Article
+instance FromJSON Article
+
+data ChargeForm = ChargeForm
+ { name :: Text
+ , email :: Text
+ , phone :: Text
+ , date :: Text
+ , articles :: [Article]
+ }
+ deriving (Show, Read, Generic, Eq)
+
+instance ToJSON ChargeForm
+instance FromJSON ChargeForm